steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-02-12 16:55:39 -05:00
parent f18ded9fc6 51c916da9d
commit 26cf8eff80
10 changed files with 416916 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/c-types/c-types.factor
View File

@ -167,7 +167,7 @@ DEFER: c-ushort-array>
swap dup length memcpy ;
: string>char-memory ( string base -- )
>r >byte-array r> byte-array>memory ;
>r B{ } like r> byte-array>memory ;
DEFER: >c-ushort-array

12
core/optimizer/specializers/specializers.factor
View File

@ -24,16 +24,18 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( word -- alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
dup { number } = [
drop tag-specializer
] [
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc
alist>quot
specializer-methods alist>quot
] if
] when* ;

8
extra/benchmark/benchmark.factor
View File

@ -1,12 +1,14 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.browser
arrays assocs io.styles io help.markup prettyprint sequences ;
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
"=== Benchmark " write dup print flush
dup require [ run ] benchmark 2array
dup require
[ [ run ] benchmark ] [ error. f f ] recover 2array
dup . ;
: run-benchmarks ( -- assoc )

110
extra/benchmark/fasta/fasta.factor Normal file
View File

@ -0,0 +1,110 @@
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
sequences.private benchmark.reverse-complement hints
byte-arrays float-arrays ;
IN: benchmark.fasta
: IM 139968 ; inline
: IA 3877 ; inline
: IC 29573 ; inline
: initial-seed 42 ; inline
: line-length 60 ; inline
USE: math.private
: random ( seed -- n seed )
>float IA * IC + IM mod [ IM /f ] keep ; inline
HINTS: random fixnum ;
: ALU "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA" ; inline
: IUB
{
{ CHAR: a 0.27 }
{ CHAR: c 0.12 }
{ CHAR: g 0.12 }
{ CHAR: t 0.27 }
{ CHAR: B 0.02 }
{ CHAR: D 0.02 }
{ CHAR: H 0.02 }
{ CHAR: K 0.02 }
{ CHAR: M 0.02 }
{ CHAR: N 0.02 }
{ CHAR: R 0.02 }
{ CHAR: S 0.02 }
{ CHAR: V 0.02 }
{ CHAR: W 0.02 }
{ CHAR: Y 0.02 }
} ; inline
: homo-sapiens
{
{ CHAR: a 0.3029549426680 }
{ CHAR: c 0.1979883004921 }
{ CHAR: g 0.1975473066391 }
{ CHAR: t 0.3015094502008 }
} ; inline
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random | seed chars floats |
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
[ rot drop select-random ] 2curry B{ } map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
:: split-lines | n quot |
n line-length /mod
[ [ line-length quot call ] times ] dip
quot call ; inline
: write-random-fasta ( seed n chars floats desc id -- seed )
write-description
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta | k len alu |
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +
] ; inline
: write-repeat-fasta ( n alu desc id -- )
write-description
[let | k! [ 0 ] alu [ ] |
[| len | k len alu make-repeat-fasta k! ] split-lines
] with-locals ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
IUB make-cumulative
[let | homo-sapiens-floats [ ]
homo-sapiens-chars [ ]
IUB-floats [ ]
IUB-chars [ ]
out [ ]
n [ ]
seed [ initial-seed ] |
out [
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed
n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
drop
] with-file-out
] with-locals ;
: run-fasta 2500000 reverse-complement-in fasta ;
MAIN: run-fasta

416672
extra/benchmark/reverse-complement/reverse-complement-in.txt Normal file
View File

File diff suppressed because it is too large Load Diff

13
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -36,10 +36,17 @@ HINTS: do-line vector string ;
500000 <vector> (reverse-complement)
] with-stream ;
: reverse-complement-in
"extra/benchmark/reverse-complement/reverse-complement-in.txt"
resource-path ;
: reverse-complement-out
"extra/benchmark/reverse-complement/reverse-complement-out.txt"
resource-path ;
: reverse-complement-main ( -- )
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply
reverse-complement-in
reverse-complement-out
reverse-complement ;
MAIN: reverse-complement-main

20
extra/locals/locals-tests.factor
View File

@ -1,5 +1,5 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces ;
namespaces arrays ;
IN: temporary
:: foo | a b | a a ;
@ -35,6 +35,21 @@ IN: temporary
:: let-test-3 | |
[let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
:: let-test-4 | |
[let | a [ 1 ] b [ ] | a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 | |
[let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 | |
[let | a [ ] b [ 1 ] | a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
[ -1 ] [ -1 let-test-3 call ] unit-test
[ 5 ] [
@ -104,7 +119,6 @@ write-test-2 "q" set
SYMBOL: a
:: use-test | a b c |
USE: kernel
;
USE: kernel ;
[ t ] [ a symbol? ] unit-test

60
extra/locals/locals.factor
View File

@ -1,10 +1,10 @@
! 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 inference.transforms parser words quotations debugger
macros arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections ;
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private ;
IN: locals
! Inspired by
@ -69,14 +69,14 @@ C: <quote> quote
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r> read-local [ set-first ] append ;
>r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
: localize ( obj args -- quot )
{
{ [ over local? ] [ read-local ] }
{ [ over quote? ] [ >r quote-local r> read-local ] }
{ [ over local-word? ] [ read-local [ call ] append ] }
{ [ over local-reader? ] [ read-local [ first ] append ] }
{ [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
@ -138,34 +138,39 @@ M: quotation free-vars { } [ add-if-free ] reduce ;
M: lambda free-vars
dup lambda-vars swap lambda-body free-vars seq-diff ;
M: let free-vars
dup let-vars swap let-body free-vars seq-diff ;
M: wlet free-vars
dup wlet-vars swap wlet-body free-vars seq-diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: lambda-rewrite* ( obj -- )
: lambda-rewrite [ lambda-rewrite* ] [ ] make ;
GENERIC: local-rewrite* ( obj -- )
UNION: block quotation lambda ;
: lambda-rewrite
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
UNION: block callable lambda ;
GENERIC: block-vars ( block -- seq )
GENERIC: block-body ( block -- quot )
M: quotation block-vars drop { } ;
M: callable block-vars drop { } ;
M: quotation block-body ;
M: callable block-body ;
M: callable local-rewrite*
[ [ local-rewrite* ] each ] [ ] make , ;
M: lambda block-vars lambda-vars ;
M: lambda block-body lambda-body ;
M: lambda local-rewrite*
dup lambda-vars swap lambda-body
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
@ -177,6 +182,8 @@ M: block lambda-rewrite*
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-locals ( seq -- words assoc )
@ -227,16 +234,17 @@ M: object lambda-rewrite* , ;
: parse-bindings ( -- alist )
scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
: let-rewrite ( words body -- )
<lambda> lambda-rewrite* \ call , ;
M: let local-rewrite*
{ let-bindings let-vars let-body } get-slots -rot
[ <reversed> ] 2apply
[
1array -rot second -rot <lambda>
[ call ] curry compose
] 2each local-rewrite* \ call , ;
M: let lambda-rewrite*
dup let-bindings values [ lambda-rewrite* \ call , ] each
{ let-vars let-body } get-slots let-rewrite ;
M: wlet lambda-rewrite*
dup wlet-bindings values [ lambda-rewrite* ] each
{ wlet-vars wlet-body } get-slots let-rewrite ;
M: wlet local-rewrite*
dup wlet-bindings values over wlet-vars rot wlet-body
<lambda> [ call ] curry compose local-rewrite* \ call , ;
: (::) ( prop -- word quot n )
>r CREATE dup reset-generic

2
extra/multiline/multiline.factor
View File

@ -16,7 +16,7 @@ IN: multiline
: STRING:
CREATE dup reset-generic
parse-here 1quotation define ; parsing
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get lexer-line-text 2dup start

62
extra/optimizer/debugger/debugger.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes inference inference.dataflow io kernel
kernel.private math.parser namespaces optimizer prettyprint
prettyprint.backend sequences words arrays match macros
assocs sequences.private ;
assocs sequences.private optimizer.specializers generic
combinators sorting math ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
@ -113,7 +114,62 @@ M: object node>quot dup class word-name comment, ;
: dataflow>quot ( node ? -- quot )
[ swap (dataflow>quot) ] [ ] make ;
: print-dataflow ( quot ? -- )
: optimized-quot. ( quot ? -- )
#! Print dataflow IR for a quotation. Flag indicates if
#! annotations should be printed or not.
>r dataflow optimize r> dataflow>quot pprint nl ;
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
SYMBOL: words-called
SYMBOL: generics-called
SYMBOL: methods-called
SYMBOL: intrinsics-called
SYMBOL: node-count
: dataflow>report ( node -- alist )
[
H{ } clone words-called set
H{ } clone generics-called set
H{ } clone methods-called set
H{ } clone intrinsics-called set
0 swap [
>r 1+ r>
dup #call? [
node-param {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
{ [ t ] [ words-called ] }
} cond 1 -rot get at+
] [
drop
] if
] each-node
node-count set
] H{ } make-assoc ;
: quot-optimize-report ( quot -- report )
dataflow optimize dataflow>report ;
: word-optimize-report ( word -- report )
word-def quot-optimize-report ;
: report. ( report -- )
[
"==== Total number of dataflow nodes:" print
node-count get .
{
{ generics-called "==== Generic word calls:" }
{ words-called "==== Ordinary word calls:" }
{ methods-called "==== Non-inlined method calls:" }
{ intrinsics-called "==== Open-coded intrinsic calls:" }
} [
nl print get keys natural-sort stack.
] assoc-each
] bind ;
: optimizer-report. ( word -- )
word-optimize-report report. ;