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

core/alien/c-types/c-types.factor

@@ -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
 

core/optimizer/specializers/specializers.factor

@@ -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 [
+            specializer-methods alist>quot
-                [ make-specializer ] keep
-                [ declare ] curry pick append
-            ] { } map>assoc
-            alist>quot
         ] if
     ] when* ;
 

extra/benchmark/benchmark.factor

@@ -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 )

extra/benchmark/fasta/fasta.factor

@@ -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

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -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"
+    reverse-complement-in
-    "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
+    reverse-complement-out
-    [ resource-path ] 2apply
     reverse-complement ;
 
 MAIN: reverse-complement-main

extra/locals/locals-tests.factor

@@ -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

extra/locals/locals.factor

@@ -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
+USING: kernel namespaces sequences sequences.private assocs math
-       math inference.transforms parser words quotations debugger
+inference.transforms parser words quotations debugger macros
-       macros arrays macros splitting combinators prettyprint.backend
+arrays macros splitting combinators prettyprint.backend
-       definitions prettyprint hashtables combinators.lib
+definitions prettyprint hashtables combinators.lib
-       prettyprint.sections ;
+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 -- )
+M: let local-rewrite*
-    <lambda> lambda-rewrite* \ call , ;
+    { 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*
+M: wlet local-rewrite*
-    dup let-bindings values [ lambda-rewrite* \ call , ] each
+    dup wlet-bindings values over wlet-vars rot wlet-body
-    { let-vars let-body } get-slots let-rewrite ;
+    <lambda> [ call ] curry compose local-rewrite* \ call , ;
-
-M: wlet lambda-rewrite*
-    dup wlet-bindings values [ lambda-rewrite* ] each
-    { wlet-vars wlet-body } get-slots let-rewrite ;
 
 : (::) ( prop -- word quot n )
     >r CREATE dup reset-generic

extra/multiline/multiline.factor

@@ -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

extra/optimizer/debugger/debugger.factor

@@ -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. ;