From 3b06cee83c7709ab3afdfb4e3a2c885bc42cdeef Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Wed, 3 Dec 2008 23:32:51 -0600
Subject: [PATCH 01/35] Obsolete tests
---
basis/io/windows/mmap/mmap-tests.factor | 8 --------
1 file changed, 8 deletions(-)
delete mode 100644 basis/io/windows/mmap/mmap-tests.factor
diff --git a/basis/io/windows/mmap/mmap-tests.factor b/basis/io/windows/mmap/mmap-tests.factor
deleted file mode 100644
index a8430108e8..0000000000
--- a/basis/io/windows/mmap/mmap-tests.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-USING: io io.mmap io.files kernel tools.test continuations
-sequences io.encodings.ascii accessors ;
-IN: io.windows.mmap.tests
-
-[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
-[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
-[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
-[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
From e304d3c9f8a31f0808ef6c7ef503f55329166dc0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 06:02:49 -0600
Subject: [PATCH 02/35] Local DCE
---
basis/compiler/tree/builder/builder.factor | 2 +-
.../backend/backend-tests.factor | 11 ++--
basis/stack-checker/backend/backend.factor | 66 +++++++++++--------
basis/stack-checker/branches/branches.factor | 41 +++++++-----
basis/stack-checker/inlining/inlining.factor | 17 +++--
.../known-words/known-words.factor | 52 +++++++++++----
basis/stack-checker/state/state.factor | 31 +++++++--
.../transforms/transforms.factor | 7 +-
core/kernel/kernel.factor | 10 +--
9 files changed, 149 insertions(+), 88 deletions(-)
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 4e79c4cd2d..b715223445 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -21,7 +21,7 @@ IN: compiler.tree.builder
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
- [ >vector meta-d set ]
+ [ >vector \ meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
diff --git a/basis/stack-checker/backend/backend-tests.factor b/basis/stack-checker/backend/backend-tests.factor
index 3bbba0fcb8..48cd10a7ee 100644
--- a/basis/stack-checker/backend/backend-tests.factor
+++ b/basis/stack-checker/backend/backend-tests.factor
@@ -3,20 +3,21 @@ stack-checker.state sequences ;
IN: stack-checker.backend.tests
[ ] [
- V{ } clone meta-d set
- V{ } clone meta-r set
+ V{ } clone \ meta-d set
+ V{ } clone \ meta-r set
+ V{ } clone \ literals set
0 d-in set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test
[ 2 ] [ 2 ensure-d length ] unit-test
-[ 2 ] [ meta-d get length ] unit-test
+[ 2 ] [ meta-d length ] unit-test
[ 3 ] [ 3 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
[ 1 ] [ 1 ensure-d length ] unit-test
-[ 3 ] [ meta-d get length ] unit-test
+[ 3 ] [ meta-d length ] unit-test
[ ] [ 1 consume-d drop ] unit-test
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 8bb19b82f7..56777cc8a7 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -9,10 +9,10 @@ stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.backend
-: push-d ( obj -- ) meta-d get push ;
+: push-d ( obj -- ) meta-d push ;
: pop-d ( -- obj )
- meta-d get [
+ meta-d [
<value> dup 1array #introduce, d-in inc
] [ pop ] if-empty ;
@@ -22,46 +22,52 @@ IN: stack-checker.backend
[ <value> ] replicate ;
: ensure-d ( n -- values )
- meta-d get 2dup length > [
+ meta-d 2dup length > [
2dup
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
- [ length d-in +@ ] [ #introduce, ] [ meta-d get push-all ] tri
- meta-d get push-all
+ [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
+ meta-d push-all
] when swap tail* ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
: consume-d ( n -- seq )
- [ ensure-d ] [ meta-d get shorten-by ] bi ;
+ [ ensure-d ] [ meta-d shorten-by ] bi ;
-: output-d ( values -- ) meta-d get push-all ;
+: output-d ( values -- ) meta-d push-all ;
: produce-d ( n -- values )
- make-values dup meta-d get push-all ;
+ make-values dup meta-d push-all ;
-: push-r ( obj -- ) meta-r get push ;
+: push-r ( obj -- ) meta-r push ;
-: pop-r ( -- obj )
- meta-r get dup empty?
+: pop-r ( -- obj )
+ meta-r dup empty?
[ too-many-r> inference-error ] [ pop ] if ;
: consume-r ( n -- seq )
- meta-r get 2dup length >
+ meta-r 2dup length >
[ too-many-r> inference-error ] when
[ swap tail* ] [ shorten-by ] 2bi ;
-: output-r ( seq -- ) meta-r get push-all ;
-
-: pop-literal ( -- rstate obj )
- pop-d
- [ 1array #drop, ]
- [ literal [ recursion>> ] [ value>> ] bi ] bi ;
-
-GENERIC: apply-object ( obj -- )
+: output-r ( seq -- ) meta-r push-all ;
: push-literal ( obj -- )
- dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
+ literals get push ;
+
+: pop-literal ( -- rstate obj )
+ literals get [
+ pop-d
+ [ 1array #drop, ]
+ [ literal [ recursion>> ] [ value>> ] bi ] bi
+ ] [ pop recursive-state get swap ] if-empty ;
+
+: literals-available? ( n -- literals ? )
+ literals get 2dup length <=
+ [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
+
+GENERIC: apply-object ( obj -- )
M: wrapper apply-object
wrapped>>
@@ -72,10 +78,17 @@ M: wrapper apply-object
M: object apply-object push-literal ;
: terminate ( -- )
- terminated? on meta-d get clone meta-r get clone #terminate, ;
+ terminated? on meta-d clone meta-r clone #terminate, ;
+
+: check->r ( -- )
+ meta-r empty? [ \ too-many->r inference-error ] unless ;
: infer-quot-here ( quot -- )
- [ apply-object terminated? get not ] all? drop ;
+ meta-r [
+ V{ } clone \ meta-r set
+ [ apply-object terminated? get not ] all?
+ [ commit-literals check->r ] [ literals get delete-all ] if
+ ] dip \ meta-r set ;
: infer-quot ( quot rstate -- )
recursive-state get [
@@ -127,13 +140,8 @@ M: object apply-object push-literal ;
: infer-word-def ( word -- )
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
-: check->r ( -- )
- meta-r get empty? terminated? get or
- [ \ too-many->r inference-error ] unless ;
-
: end-infer ( -- )
- check->r
- meta-d get clone #return, ;
+ meta-d clone #return, ;
: effect-required? ( word -- ? )
{
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index 7b461d0028..e4c11960de 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -57,9 +57,9 @@ SYMBOL: quotations
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
- [ d-in branch-variable ] [ meta-d active-variable ] bi
+ [ d-in branch-variable ] [ \ meta-d active-variable ] bi
unify-branches
- [ d-in set ] [ ] [ dup >vector meta-d set ] tri* ;
+ [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
: terminated-phi ( seq -- terminated )
terminated? branch-variable ;
@@ -74,17 +74,25 @@ SYMBOL: quotations
tri ;
: copy-inference ( -- )
- meta-d [ clone ] change
- V{ } clone meta-r set
+ \ meta-d [ clone ] change
+ literals [ clone ] change
d-in [ ] change ;
-: infer-branch ( literal -- namespace )
+GENERIC: infer-branch ( literal -- namespace )
+
+M: literal infer-branch
[
copy-inference
nest-visitor
[ value>> quotation set ] [ infer-literal-quot ] bi
- check->r
- ] H{ } make-assoc ; inline
+ ] H{ } make-assoc ;
+
+M: callable infer-branch
+ [
+ copy-inference
+ nest-visitor
+ [ quotation set ] [ infer-quot-here ] bi
+ ] H{ } make-assoc ;
: infer-branches ( branches -- input children data )
[ pop-d ] dip
@@ -96,16 +104,19 @@ SYMBOL: quotations
[ first2 #if, ] dip compute-phi-function ;
: infer-if ( -- )
- 2 consume-d
- dup [ known [ curried? ] [ composed? ] bi or ] contains? [
- output-d
- [ rot [ drop call ] [ nip call ] if ]
- infer-quot-here
+ 2 literals-available? [
+ (infer-if)
] [
- [ #drop, ] [ [ literal ] map (infer-if) ] bi
+ drop 2 consume-d
+ dup [ known [ curried? ] [ composed? ] bi or ] contains? [
+ output-d
+ [ rot [ drop call ] [ nip call ] if ]
+ infer-quot-here
+ ] [
+ [ #drop, ] [ [ literal ] map (infer-if) ] bi
+ ] if
] if ;
: infer-dispatch ( -- )
- pop-literal nip [ <literal> ] map
- infer-branches
+ pop-literal nip infer-branches
[ #dispatch, ] dip compute-phi-function ;
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index df0145b73e..23283fb6e3 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -51,14 +51,14 @@ SYMBOL: enter-out
: prepare-stack ( word -- )
required-stack-effect in>>
[ length ensure-d drop ] [
- meta-d get clone enter-in set
- meta-d get swap make-copies enter-out set
+ meta-d clone enter-in set
+ meta-d swap make-copies enter-out set
] bi ;
: emit-enter-recursive ( label -- )
enter-out get >>enter-out
enter-in get enter-out get #enter-recursive,
- enter-out get >vector meta-d set ;
+ enter-out get >vector \ meta-d set ;
: entry-stack-height ( label -- stack )
enter-out>> length ;
@@ -77,7 +77,7 @@ SYMBOL: enter-out
: end-recursive-word ( word label -- )
[ check-return ]
- [ meta-d get dup copy-values dup meta-d set #return-recursive, ]
+ [ meta-d dup copy-values dup \ meta-d set #return-recursive, ]
bi ;
: recursive-word-inputs ( label -- n )
@@ -95,10 +95,8 @@ SYMBOL: enter-out
[ nip ]
2tri
- check->r
-
dup recursive-word-inputs
- meta-d get
+ meta-d
stack-visitor get
terminated? get
] with-scope ;
@@ -116,7 +114,7 @@ SYMBOL: enter-out
swap word>> required-stack-effect in>> length tail* ;
: call-site-stack ( label -- stack )
- meta-d get trim-stack ;
+ meta-d trim-stack ;
: trimmed-enter-out ( label -- stack )
dup enter-out>> trim-stack ;
@@ -131,7 +129,7 @@ SYMBOL: enter-out
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi
- meta-d get length pick length [-]
+ meta-d length pick length [-]
object <repetition> '[ _ prepend ] bi@
<effect> ;
@@ -142,6 +140,7 @@ SYMBOL: enter-out
] [ drop undeclared-recursion-error inference-error ] if ;
: inline-word ( word -- )
+ commit-literals
[ inlined-dependency depends-on ]
[
dup inline-recursive-label [
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 12eb637964..26e1b81c93 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -63,7 +63,9 @@ IN: stack-checker.known-words
GENERIC: infer-call* ( value known -- )
-: infer-call ( value -- ) dup known infer-call* ;
+: (infer-call) ( value -- ) dup known infer-call* ;
+
+: infer-call ( -- ) pop-d (infer-call) ;
M: literal infer-call*
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
@@ -73,7 +75,7 @@ M: curried infer-call*
[ uncurry ] infer-quot-here
[ quot>> known pop-d [ set-known ] keep ]
[ obj>> known pop-d [ set-known ] keep ] bi
- push-d infer-call ;
+ push-d (infer-call) ;
M: composed infer-call*
swap push-d
@@ -81,20 +83,41 @@ M: composed infer-call*
[ quot2>> known pop-d [ set-known ] keep ]
[ quot1>> known pop-d [ set-known ] keep ] bi
push-d push-d
- 1 infer->r pop-d infer-call
- terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
+ 1 infer->r infer-call
+ terminated? get [ 1 infer-r> infer-call ] unless ;
M: object infer-call*
\ literal-expected inference-warning ;
: infer-slip ( -- )
- 1 infer->r pop-d infer-call 1 infer-r> ;
+ 1 infer->r infer-call 1 infer-r> ;
: infer-2slip ( -- )
- 2 infer->r pop-d infer-call 2 infer-r> ;
+ 2 infer->r infer-call 2 infer-r> ;
: infer-3slip ( -- )
- 3 infer->r pop-d infer-call 3 infer-r> ;
+ 3 infer->r infer-call 3 infer-r> ;
+
+: infer-dip ( -- )
+ commit-literals
+ literals get
+ [ \ dip def>> infer-quot-here ]
+ [ pop 1 infer->r infer-quot-here 1 infer-r> ]
+ if-empty ;
+
+: infer-2dip ( -- )
+ commit-literals
+ literals get
+ [ \ 2dip def>> infer-quot-here ]
+ [ pop 2 infer->r infer-quot-here 2 infer-r> ]
+ if-empty ;
+
+: infer-3dip ( -- )
+ commit-literals
+ literals get
+ [ \ 3dip def>> infer-quot-here ]
+ [ pop 3 infer->r infer-quot-here 3 infer-r> ]
+ if-empty ;
: infer-curry ( -- )
2 consume-d
@@ -157,11 +180,14 @@ M: object infer-call*
{ \ >r [ 1 infer->r ] }
{ \ r> [ 1 infer-r> ] }
{ \ declare [ infer-declare ] }
- { \ call [ pop-d infer-call ] }
- { \ (call) [ pop-d infer-call ] }
+ { \ call [ infer-call ] }
+ { \ (call) [ infer-call ] }
{ \ slip [ infer-slip ] }
{ \ 2slip [ infer-2slip ] }
{ \ 3slip [ infer-3slip ] }
+ { \ dip [ infer-dip ] }
+ { \ 2dip [ infer-2dip ] }
+ { \ 3dip [ infer-3dip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
@@ -190,10 +216,10 @@ M: object infer-call*
"local-word-def" word-prop infer-quot-here ;
{
- >r r> declare call (call) slip 2slip 3slip curry compose
- execute (execute) if dispatch <tuple-boa> (throw)
- load-locals get-local drop-locals do-primitive alien-invoke
- alien-indirect alien-callback
+ >r r> declare call (call) slip 2slip 3slip dip 2dip 3dip
+ curry compose execute (execute) if dispatch <tuple-boa>
+ (throw) load-locals get-local drop-locals do-primitive
+ alien-invoke alien-indirect alien-callback
} [ t "special" set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 2706ec60ef..130147f798 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs arrays namespaces sequences kernel definitions
math effects accessors words fry classes.algebra
-compiler.units ;
+compiler.units stack-checker.values stack-checker.visitor ;
IN: stack-checker.state
! Did the current control-flow path throw an error?
@@ -11,23 +11,40 @@ SYMBOL: terminated?
! Number of inputs current word expects from the stack
SYMBOL: d-in
+DEFER: commit-literals
+
! Compile-time data stack
-SYMBOL: meta-d
+: meta-d ( -- stack ) commit-literals \ meta-d get ;
! Compile-time retain stack
-SYMBOL: meta-r
+: meta-r ( -- stack ) \ meta-r get ;
-: current-stack-height ( -- n ) meta-d get length d-in get - ;
+! Uncommitted literals. This is a form of local dead-code
+! elimination; the goal is to reduce the number of IR nodes
+! which get constructed. Technically it is redundant since
+! we do global DCE later, but it speeds up compile time.
+SYMBOL: literals
+
+: (push-literal) ( obj -- )
+ dup <literal> make-known
+ [ nip \ meta-d get push ] [ #push, ] 2bi ;
+
+: commit-literals ( -- )
+ literals get [
+ [ [ (push-literal) ] each ] [ delete-all ] bi
+ ] unless-empty ;
+
+: current-stack-height ( -- n ) meta-d length d-in get - ;
: current-effect ( -- effect )
d-in get
- meta-d get length <effect>
+ meta-d length <effect>
terminated? get >>terminated? ;
: init-inference ( -- )
terminated? off
- V{ } clone meta-d set
- V{ } clone meta-r set
+ V{ } clone \ meta-d set
+ V{ } clone literals set
0 d-in set ;
! Words that the current quotation depends on
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 7eec29f94b..299dc1b551 100644
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -19,11 +19,8 @@ IN: stack-checker.transforms
rot with-datastack first2
dup [
[
- [ drop ] [
- [ length meta-d get '[ _ pop* ] times ]
- [ #drop, ]
- bi
- ] bi*
+ [ drop ]
+ [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
] 2dip
swap infer-quot
] [
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index bbe2d348d8..98dc0e50fa 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -52,7 +52,9 @@ DEFER: if
: ?if ( default cond true false -- )
pick [ roll 2drop call ] [ 2nip call ] if ; inline
-! Slippers
+! Slippers and dippers.
+! Not declared inline because the compiler special-cases them
+
: slip ( quot x -- x )
#! 'slip' and 'dip' can be defined in terms of each other
#! because the JIT special-cases a 'dip' preceeded by
@@ -71,11 +73,11 @@ DEFER: if
#! a literal quotation.
[ call ] 3dip ;
-: dip ( x quot -- x ) swap slip ; inline
+: dip ( x quot -- x ) swap slip ;
-: 2dip ( x y quot -- x y ) -rot 2slip ; inline
+: 2dip ( x y quot -- x y ) -rot 2slip ;
-: 3dip ( x y z quot -- x y z ) -roll 3slip ; inline
+: 3dip ( x y z quot -- x y z ) -roll 3slip ;
! Keepers
: keep ( x quot -- x ) over slip ; inline
From 0e060c5cfdaa09d679b3b6546e8193b9c181ee1d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 4 Dec 2008 06:28:49 -0600
Subject: [PATCH 03/35] fix db load error
---
basis/db/postgresql/postgresql.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
index 82d96c4af1..90a875b8ff 100644
--- a/basis/db/postgresql/postgresql.factor
+++ b/basis/db/postgresql/postgresql.factor
@@ -267,7 +267,7 @@ ERROR: no-compound-found string object ;
M: postgresql-db compound ( string object -- string' )
over {
{ "default" [ first number>string " " glue ] }
- { "varchar" [ first number>string paren append ] }
+ { "varchar" [ first number>string "(" ")" surround append ] }
{ "references" [ >reference-string ] }
[ drop no-compound-found ]
} case ;
From 041d2f328623da3d14ec5477cd186f8f97e1140d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 4 Dec 2008 06:31:08 -0600
Subject: [PATCH 04/35] fix load error
---
extra/hardware-info/windows/nt/nt.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor
index 6215566f11..dafa90bcec 100755
--- a/extra/hardware-info/windows/nt/nt.factor
+++ b/extra/hardware-info/windows/nt/nt.factor
@@ -1,6 +1,7 @@
USING: alien alien.c-types alien.strings
kernel libc math namespaces hardware-info.backend
-windows windows.advapi32 windows.kernel32 system ;
+hardware-info.windows windows windows.advapi32
+windows.kernel32 system ;
IN: hardware-info.windows.nt
M: winnt cpus ( -- n )
From fa6a2047f04885e276d6e060c9c38922430608cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 07:05:59 -0600
Subject: [PATCH 05/35] New inlining heuristic: number of usages within this
word. Speeds up bootstrap by 10%
---
.../tree/propagation/inlining/inlining.factor | 26 ++++++++++++++-----
.../tree/propagation/nodes/nodes.factor | 2 ++
.../tree/propagation/propagation.factor | 1 +
.../propagation/recursive/recursive.factor | 4 +++
4 files changed, 26 insertions(+), 7 deletions(-)
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 83a4a7aef7..3a94029756 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -20,6 +20,10 @@ SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
+! We try not to inline the same word too many times, to avoid
+! combinatorial explosion
+SYMBOL: inlining-count
+
! Splicing nodes
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
@@ -120,17 +124,25 @@ DEFER: (flat-length)
bi and
] contains? ;
+: node-count-bias ( -- n )
+ 45 node-count get [-] 8 /i ;
+
+: body-length-bias ( word -- n )
+ [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
+ 24 swap [-] 4 /i ;
+
: inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
[
{
- [ drop node-count get 45 swap [-] 8 /i ]
- [ flat-length 24 swap [-] 4 /i ]
+ [ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
- ] bi* + + + + + ;
+ node-count-bias
+ loop-nesting get 0 or 2 *
+ ] bi* + + + + + + ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@@ -138,12 +150,12 @@ DEFER: (flat-length)
SYMBOL: history
: remember-inlining ( word -- )
- history [ swap suffix ] change ;
+ [ [ 1 ] dip inlining-count get at+ ]
+ [ history [ swap suffix ] change ]
+ bi ;
: inline-word-def ( #call word quot -- ? )
- over history get memq? [
- 3drop f
- ] [
+ over history get memq? [ 3drop f ] [
[
swap remember-inlining
dupd splicing-nodes >>body
diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor
index 9e4d99e462..d676102bde 100644
--- a/basis/compiler/tree/propagation/nodes/nodes.factor
+++ b/basis/compiler/tree/propagation/nodes/nodes.factor
@@ -6,6 +6,8 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
+SYMBOL: loop-nesting
+
GENERIC: propagate-before ( node -- )
GENERIC: propagate-after ( node -- )
diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
index b9822d2c6b..2a9825e3f1 100644
--- a/basis/compiler/tree/propagation/propagation.factor
+++ b/basis/compiler/tree/propagation/propagation.factor
@@ -19,5 +19,6 @@ IN: compiler.tree.propagation
H{ } clone copies set
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
+ H{ } clone inlining-count set
dup count-nodes
dup (propagate) ;
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 7f10f87016..ff9f262d28 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
M: #recursive propagate-around ( #recursive -- )
constraints [ H{ } clone suffix ] change
[
+ loop-nesting inc
+
constraints [ but-last H{ } clone suffix ] change
child>>
@@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
[ first propagate-recursive-phi ]
[ (propagate) ]
tri
+
+ loop-nesting dec
] until-fixed-point ;
: recursive-phi-infos ( node -- infos )
From 237c8bb42a7e9407e99e43de5c7fe651d9482e4f Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Wed, 3 Dec 2008 23:36:28 -0600
Subject: [PATCH 06/35] Fix load error in hardware-info
---
extra/hardware-info/windows/nt/nt.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor
index dafa90bcec..6274e7974c 100755
--- a/extra/hardware-info/windows/nt/nt.factor
+++ b/extra/hardware-info/windows/nt/nt.factor
@@ -1,7 +1,7 @@
USING: alien alien.c-types alien.strings
kernel libc math namespaces hardware-info.backend
hardware-info.windows windows windows.advapi32
-windows.kernel32 system ;
+windows.kernel32 system byte-arrays ;
IN: hardware-info.windows.nt
M: winnt cpus ( -- n )
From ba31f73b41516d4dbf1e017ae9cb885f45b58740 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 10:19:05 -0600
Subject: [PATCH 07/35] Fix regression on >r/r> test
---
basis/stack-checker/backend/backend.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 56777cc8a7..07030085a6 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -116,10 +116,10 @@ M: object apply-object push-literal ;
] if ;
: infer->r ( n -- )
- consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
+ consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
: infer-r> ( n -- )
- consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
+ consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
From 9172a3ae276615c069a395ad5ecbc7d5b47842af Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 10:19:18 -0600
Subject: [PATCH 08/35] Change usages of >r/r> in unicode.*
---
basis/unicode/breaks/breaks.factor | 2 +-
basis/unicode/collation/collation.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 0f2e12119d..58c7a5d10e 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -72,7 +72,7 @@ VALUE: grapheme-table
grapheme-table nth nth not ;
: chars ( i str n -- str[i] str[i+n] )
- swap >r dupd + r> [ ?nth ] curry bi@ ;
+ swap [ dupd + ] dip [ ?nth ] curry bi@ ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline
diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor
index 7f445b8513..90b280ee09 100644
--- a/basis/unicode/collation/collation.factor
+++ b/basis/unicode/collation/collation.factor
@@ -124,7 +124,7 @@ PRIVATE>
[ zero? ] tri@ and and ;
: filter-ignorable ( weights -- weights' )
- >r f r> [
+ f swap [
tuck primary>> zero? and
[ swap ignorable?>> or ]
[ swap completely-ignorable? or not ] 2bi
From 293dc2062c11f9f45ed8001289d24993c48a69cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 12:07:33 -0600
Subject: [PATCH 09/35] Generalize specialized-arrays.direct: it should be able
to wrap a byte array
---
basis/specialized-arrays/direct/functor/functor.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index 2cde26b731..14fb739947 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -20,7 +20,7 @@ SET-NTH [ T dup c-setter array-accessor ]
WHERE
TUPLE: A
-{ underlying alien read-only }
+{ underlying c-ptr read-only }
{ length fixnum read-only } ;
: <A> ( alien len -- direct-array ) A boa ; inline
From e7d11f3b9cb63773a4f78f800115318a75202783 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 4 Dec 2008 13:10:19 -0600
Subject: [PATCH 10/35] Add 'extra/sto'
---
extra/sto/sto.factor | 20 ++++++++++++++++++++
1 file changed, 20 insertions(+)
create mode 100644 extra/sto/sto.factor
diff --git a/extra/sto/sto.factor b/extra/sto/sto.factor
new file mode 100644
index 0000000000..b43c9cc359
--- /dev/null
+++ b/extra/sto/sto.factor
@@ -0,0 +1,20 @@
+
+USING: kernel lexer parser words quotations compiler.units ;
+
+IN: sto
+
+! Use 'sto' to bind a value on the stack to a word.
+!
+! Example:
+!
+! 10 sto A
+
+: sto
+ \ 1quotation parsed
+ scan
+ current-vocab create
+ dup set-word
+ literalize parsed
+ \ swap parsed
+ [ define ] parsed
+ \ with-compilation-unit parsed ; parsing
From f5bafbb2a938df325240904e2f2af5cf614e3cc9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 4 Dec 2008 13:53:03 -0600
Subject: [PATCH 11/35] better default scite path
---
basis/editors/scite/scite.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor
index aa5c5ef2a1..10152f53d5 100644
--- a/basis/editors/scite/scite.factor
+++ b/basis/editors/scite/scite.factor
@@ -14,7 +14,10 @@ IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
- program-files "wscite\\SciTE.exe" append-path
+ program-files "ScITE Source Code Editor\\SciTE.exe" append-path
+ dup exists? [
+ drop program-files "wscite\\SciTE.exe" append-path
+ ] unless
] unless* ;
: scite-command ( file line -- cmd )
From f990647d672e5e5fe72745de8367969d71b080cc Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 13:40:55 -0800
Subject: [PATCH 12/35] Renovate math.blas.vectors to build off of functors and
specialized-arrays. Add complex and complex-components sequence wrappers. Fix
small bug in functors
---
basis/functors/functors.factor | 2 +-
extra/math/blas/cblas/cblas.factor | 44 +-
extra/math/blas/vectors/vectors-docs.factor | 2 +-
extra/math/blas/vectors/vectors.factor | 458 ++++++++----------
.../sequences/complex-components/authors.txt | 1 +
.../complex-components-docs.factor | 33 ++
.../complex-components-tests.factor | 16 +
.../complex-components.factor | 28 ++
.../sequences/complex-components/summary.txt | 1 +
extra/sequences/complex-components/tags.txt | 2 +
extra/sequences/complex/authors.txt | 1 +
extra/sequences/complex/complex-docs.factor | 29 ++
extra/sequences/complex/complex-tests.factor | 26 +
extra/sequences/complex/complex.factor | 25 +
extra/sequences/complex/summary.txt | 1 +
extra/sequences/complex/tags.txt | 2 +
16 files changed, 395 insertions(+), 276 deletions(-)
create mode 100644 extra/sequences/complex-components/authors.txt
create mode 100644 extra/sequences/complex-components/complex-components-docs.factor
create mode 100644 extra/sequences/complex-components/complex-components-tests.factor
create mode 100644 extra/sequences/complex-components/complex-components.factor
create mode 100644 extra/sequences/complex-components/summary.txt
create mode 100644 extra/sequences/complex-components/tags.txt
create mode 100644 extra/sequences/complex/authors.txt
create mode 100644 extra/sequences/complex/complex-docs.factor
create mode 100644 extra/sequences/complex/complex-tests.factor
create mode 100644 extra/sequences/complex/complex.factor
create mode 100644 extra/sequences/complex/summary.txt
create mode 100644 extra/sequences/complex/tags.txt
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index d5ac3b6878..7126806c3d 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -17,7 +17,7 @@ IN: functors
scan-param parsed
scan {
{ ";" [ tuple parsed f parsed ] }
- { "<" [ scan-param [ parse-tuple-slots ] { } make parsed ] }
+ { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
[
[ tuple parsed ] dip
[ parse-slot-name [ parse-tuple-slots ] when ] { }
diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor
index 58f179af80..4c0a88f929 100644
--- a/extra/math/blas/cblas/cblas.factor
+++ b/extra/math/blas/cblas/cblas.factor
@@ -34,10 +34,10 @@ TYPEDEF: int CBLAS_SIDE
TYPEDEF: int CBLAS_INDEX
-C-STRUCT: CBLAS_C
+C-STRUCT: float-complex
{ "float" "real" }
{ "float" "imag" } ;
-C-STRUCT: CBLAS_Z
+C-STRUCT: double-complex
{ "double" "real" }
{ "double" "imag" } ;
@@ -53,14 +53,14 @@ FUNCTION: double cblas_ddot
( int N, double* X, int incX, double* Y, int incY ) ;
FUNCTION: void cblas_cdotu_sub
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ;
+ ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
FUNCTION: void cblas_cdotc_sub
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ;
+ ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
FUNCTION: void cblas_zdotu_sub
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ;
+ ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
FUNCTION: void cblas_zdotc_sub
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotc ) ;
+ ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
FUNCTION: float cblas_snrm2
( int N, float* X, int incX ) ;
@@ -73,23 +73,23 @@ FUNCTION: double cblas_dasum
( int N, double* X, int incX ) ;
FUNCTION: float cblas_scnrm2
- ( int N, CBLAS_C* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: float cblas_scasum
- ( int N, CBLAS_C* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: double cblas_dznrm2
- ( int N, CBLAS_Z* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: double cblas_dzasum
- ( int N, CBLAS_Z* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_isamax
( int N, float* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_idamax
( int N, double* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_icamax
- ( int N, CBLAS_C* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: CBLAS_INDEX cblas_izamax
- ( int N, CBLAS_Z* X, int incX ) ;
+ ( int N, void* X, int incX ) ;
FUNCTION: void cblas_sswap
( int N, float* X, int incX, float* Y, int incY ) ;
@@ -106,31 +106,31 @@ FUNCTION: void cblas_daxpy
( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
FUNCTION: void cblas_cswap
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+ ( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_ccopy
- ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+ ( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_caxpy
- ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ;
+ ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zswap
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+ ( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zcopy
- ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+ ( int N, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_zaxpy
- ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ;
+ ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
FUNCTION: void cblas_sscal
( int N, float alpha, float* X, int incX ) ;
FUNCTION: void cblas_dscal
( int N, double alpha, double* X, int incX ) ;
FUNCTION: void cblas_cscal
- ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX ) ;
+ ( int N, void* alpha, void* X, int incX ) ;
FUNCTION: void cblas_zscal
- ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ;
+ ( int N, void* alpha, void* X, int incX ) ;
FUNCTION: void cblas_csscal
- ( int N, float alpha, CBLAS_C* X, int incX ) ;
+ ( int N, float alpha, void* X, int incX ) ;
FUNCTION: void cblas_zdscal
- ( int N, double alpha, CBLAS_Z* X, int incX ) ;
+ ( int N, double alpha, void* X, int incX ) ;
FUNCTION: void cblas_srotg
( float* a, float* b, float* c, float* s ) ;
diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor
index 0595f00989..cb26d67334 100644
--- a/extra/math/blas/vectors/vectors-docs.factor
+++ b/extra/math/blas/vectors/vectors-docs.factor
@@ -37,7 +37,7 @@ HELP: blas-vector-base
}
"All of these subclasses share the same tuple layout:"
{ $list
- { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
+ { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" }
{ { $snippet "length" } " indicates the length of the vector;" }
{ "and " { $snippet "inc" } " indicates the distance, in elements, between elements." }
} } ;
diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index f29ef30ab7..c229012370 100755
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -1,231 +1,77 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel macros math math.blas.cblas
-math.complex math.functions math.order multi-methods qualified
-sequences sequences.private generalizations
+combinators.short-circuit fry kernel math math.blas.cblas
+math.complex math.functions math.order sequences.complex
+sequences.complex-components sequences sequences.private
+generalizations functors words locals
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double ;
-QUALIFIED: syntax
IN: math.blas.vectors
-TUPLE: blas-vector-base data length inc ;
-TUPLE: float-blas-vector < blas-vector-base ;
-TUPLE: double-blas-vector < blas-vector-base ;
-TUPLE: float-complex-blas-vector < blas-vector-base ;
-TUPLE: double-complex-blas-vector < blas-vector-base ;
+TUPLE: blas-vector-base underlying length inc ;
-INSTANCE: float-blas-vector sequence
-INSTANCE: double-blas-vector sequence
-INSTANCE: float-complex-blas-vector sequence
-INSTANCE: double-complex-blas-vector sequence
+INSTANCE: blas-vector-base virtual-sequence
-C: <float-blas-vector> float-blas-vector
-C: <double-blas-vector> double-blas-vector
-C: <float-complex-blas-vector> float-complex-blas-vector
-C: <double-complex-blas-vector> double-complex-blas-vector
+GENERIC: element-type ( v -- type )
GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
GENERIC: n*V! ( alpha x -- x=alpha*x )
-
GENERIC: V. ( x y -- x.y )
GENERIC: V.conj ( x y -- xconj.y )
GENERIC: Vnorm ( x -- norm )
GENERIC: Vasum ( x -- sum )
GENERIC: Vswap ( x y -- x=y y=x )
-
GENERIC: Viamax ( x -- max-i )
-GENERIC: element-type ( v -- type )
-
-METHOD: element-type { float-blas-vector }
- drop "float" ;
-METHOD: element-type { double-blas-vector }
- drop "double" ;
-METHOD: element-type { float-complex-blas-vector }
- drop "CBLAS_C" ;
-METHOD: element-type { double-complex-blas-vector }
- drop "CBLAS_Z" ;
-
<PRIVATE
GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
-METHOD: (blas-vector-like) { object object object float-blas-vector }
- drop <float-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-blas-vector }
- drop <double-blas-vector> ;
-METHOD: (blas-vector-like) { object object object float-complex-blas-vector }
- drop <float-complex-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-complex-blas-vector }
- drop <double-complex-blas-vector> ;
+GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
-: (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc )
- [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip
- 4 npick * <byte-array>
- 1 ;
+: shorter-length ( v1 v2 -- length )
+ [ length>> ] bi@ min ; inline
+: data-and-inc ( v -- data inc )
+ [ underlying>> ] [ inc>> ] bi ; inline
+: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
+ [ data-and-inc ] bi@ ; inline
-MACRO: (do-copy) ( copy make-vector -- )
- '[ over 6 npick _ 2dip 1 @ ] ;
+:: (prepare-copy)
+ ( v element-size -- length v-data v-inc v-dest-data v-dest-inc
+ copy-data copy-length copy-inc )
+ v [ length>> ] [ data-and-inc ] bi
+ v length>> element-size * <byte-array>
+ 1
+ over v length>> 1 ;
-: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 )
- [
- [ [ length>> ] bi@ min ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
- ] 2keep ;
+: (prepare-swap)
+ ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
+ v1 v2 )
+ [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
-: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 )
- [
- [ [ length>> ] bi@ min swap ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi
- ] keep ;
+:: (prepare-axpy)
+ ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
+ v2 )
+ v1 v2 shorter-length
+ n
+ v1 v2 datas-and-incs
+ v2 ;
-: (prepare-scal) ( n v -- length n v-data v-inc v )
- [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ;
+:: (prepare-scal)
+ ( n v -- length n v-data v-inc
+ v )
+ v length>>
+ n
+ v data-and-inc
+ v ;
: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
- [ [ length>> ] bi@ min ]
- [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ;
+ [ shorter-length ] [ datas-and-incs ] 2bi ;
-: (prepare-nrm2) ( v -- length v1-data v1-inc )
- [ length>> ] [ data>> ] [ inc>> ] tri ;
-
-: (flatten-complex-sequence) ( seq -- seq' )
- [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ;
-
-: (>c-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi float-array{ } 2sequence underlying>> ;
-: (>z-complex) ( complex -- alien )
- [ real-part ] [ imaginary-part ] bi double-array{ } 2sequence underlying>> ;
-
-: (c-complex>) ( alien -- complex )
- 2 <direct-float-array> first2 rect> ;
-: (z-complex>) ( alien -- complex )
- 2 <direct-double-array> first2 rect> ;
-
-: (prepare-nth) ( n v -- n*inc v-data )
- [ inc>> ] [ data>> ] bi [ * ] dip ;
-
-MACRO: (complex-nth) ( nth-quot -- )
- '[
- [ 2 * dup 1+ ] dip
- _ curry bi@ rect>
- ] ;
-
-: (c-complex-nth) ( n alien -- complex )
- [ float-nth ] (complex-nth) ;
-: (z-complex-nth) ( n alien -- complex )
- [ double-nth ] (complex-nth) ;
-
-MACRO: (set-complex-nth) ( set-nth-quot -- )
- '[
- [
- [ [ real-part ] [ imaginary-part ] bi ]
- [ 2 * dup 1+ ] bi*
- swapd
- ] dip
- _ curry 2bi@
- ] ;
-
-: (set-c-complex-nth) ( complex n alien -- )
- [ set-float-nth ] (set-complex-nth) ;
-: (set-z-complex-nth) ( complex n alien -- )
- [ set-double-nth ] (set-complex-nth) ;
+: (prepare-nrm2) ( v -- length data inc )
+ [ length>> ] [ data-and-inc ] bi ;
PRIVATE>
-: <zero-vector> ( exemplar -- zero )
- [ element-type <c-object> ]
- [ length>> 0 ]
- [ (blas-vector-like) ] tri ;
-
-: <empty-vector> ( length exemplar -- vector )
- [ element-type <c-array> ]
- [ 1 swap ] 2bi
- (blas-vector-like) ;
-
-syntax:M: blas-vector-base length
- length>> ;
-
-syntax:M: float-blas-vector nth-unsafe
- (prepare-nth) float-nth ;
-syntax:M: float-blas-vector set-nth-unsafe
- (prepare-nth) set-float-nth ;
-
-syntax:M: double-blas-vector nth-unsafe
- (prepare-nth) double-nth ;
-syntax:M: double-blas-vector set-nth-unsafe
- (prepare-nth) set-double-nth ;
-
-syntax:M: float-complex-blas-vector nth-unsafe
- (prepare-nth) (c-complex-nth) ;
-syntax:M: float-complex-blas-vector set-nth-unsafe
- (prepare-nth) (set-c-complex-nth) ;
-
-syntax:M: double-complex-blas-vector nth-unsafe
- (prepare-nth) (z-complex-nth) ;
-syntax:M: double-complex-blas-vector set-nth-unsafe
- (prepare-nth) (set-z-complex-nth) ;
-
-syntax:M: blas-vector-base equal?
- {
- [ [ length ] bi@ = ]
- [ [ = ] 2all? ]
- } 2&& ;
-
-: >float-blas-vector ( seq -- v )
- [ >float-array underlying>> ] [ length ] bi 1 <float-blas-vector> ;
-: >double-blas-vector ( seq -- v )
- [ >double-array underlying>> ] [ length ] bi 1 <double-blas-vector> ;
-: >float-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >float-array underlying>> ] [ length ] bi
- 1 <float-complex-blas-vector> ;
-: >double-complex-blas-vector ( seq -- v )
- [ (flatten-complex-sequence) >double-array underlying>> ] [ length ] bi
- 1 <double-complex-blas-vector> ;
-
-syntax:M: float-blas-vector clone
- "float" heap-size (prepare-copy)
- [ cblas_scopy ] [ <float-blas-vector> ] (do-copy) ;
-syntax:M: double-blas-vector clone
- "double" heap-size (prepare-copy)
- [ cblas_dcopy ] [ <double-blas-vector> ] (do-copy) ;
-syntax:M: float-complex-blas-vector clone
- "CBLAS_C" heap-size (prepare-copy)
- [ cblas_ccopy ] [ <float-complex-blas-vector> ] (do-copy) ;
-syntax:M: double-complex-blas-vector clone
- "CBLAS_Z" heap-size (prepare-copy)
- [ cblas_zcopy ] [ <double-complex-blas-vector> ] (do-copy) ;
-
-METHOD: Vswap { float-blas-vector float-blas-vector }
- (prepare-swap) [ cblas_sswap ] 2dip ;
-METHOD: Vswap { double-blas-vector double-blas-vector }
- (prepare-swap) [ cblas_dswap ] 2dip ;
-METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
- (prepare-swap) [ cblas_cswap ] 2dip ;
-METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector }
- (prepare-swap) [ cblas_zswap ] 2dip ;
-
-METHOD: n*V+V! { real float-blas-vector float-blas-vector }
- (prepare-axpy) [ cblas_saxpy ] dip ;
-METHOD: n*V+V! { real double-blas-vector double-blas-vector }
- (prepare-axpy) [ cblas_daxpy ] dip ;
-METHOD: n*V+V! { number float-complex-blas-vector float-complex-blas-vector }
- [ (>c-complex) ] 2dip
- (prepare-axpy) [ cblas_caxpy ] dip ;
-METHOD: n*V+V! { number double-complex-blas-vector double-complex-blas-vector }
- [ (>z-complex) ] 2dip
- (prepare-axpy) [ cblas_zaxpy ] dip ;
-
-METHOD: n*V! { real float-blas-vector }
- (prepare-scal) [ cblas_sscal ] dip ;
-METHOD: n*V! { real double-blas-vector }
- (prepare-scal) [ cblas_dscal ] dip ;
-METHOD: n*V! { number float-complex-blas-vector }
- [ (>c-complex) ] dip
- (prepare-scal) [ cblas_cscal ] dip ;
-METHOD: n*V! { number double-complex-blas-vector }
- [ (>z-complex) ] dip
- (prepare-scal) [ cblas_zscal ] dip ;
-
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
@@ -242,62 +88,170 @@ METHOD: n*V! { number double-complex-blas-vector }
: V/n ( x alpha -- x/alpha )
recip swap n*V ; inline
-METHOD: V. { float-blas-vector float-blas-vector }
- (prepare-dot) cblas_sdot ;
-METHOD: V. { double-blas-vector double-blas-vector }
- (prepare-dot) cblas_ddot ;
-METHOD: V. { float-complex-blas-vector float-complex-blas-vector }
- (prepare-dot)
- "CBLAS_C" <c-object> [ cblas_cdotu_sub ] keep (c-complex>) ;
-METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
- (prepare-dot)
- "CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
-
-METHOD: V.conj { float-blas-vector float-blas-vector }
- (prepare-dot) cblas_sdot ;
-METHOD: V.conj { double-blas-vector double-blas-vector }
- (prepare-dot) cblas_ddot ;
-METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
- (prepare-dot)
- "CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
-METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector }
- (prepare-dot)
- "CBLAS_Z" <c-object> [ cblas_zdotc_sub ] keep (z-complex>) ;
-
-METHOD: Vnorm { float-blas-vector }
- (prepare-nrm2) cblas_snrm2 ;
-METHOD: Vnorm { double-blas-vector }
- (prepare-nrm2) cblas_dnrm2 ;
-METHOD: Vnorm { float-complex-blas-vector }
- (prepare-nrm2) cblas_scnrm2 ;
-METHOD: Vnorm { double-complex-blas-vector }
- (prepare-nrm2) cblas_dznrm2 ;
-
-METHOD: Vasum { float-blas-vector }
- (prepare-nrm2) cblas_sasum ;
-METHOD: Vasum { double-blas-vector }
- (prepare-nrm2) cblas_dasum ;
-METHOD: Vasum { float-complex-blas-vector }
- (prepare-nrm2) cblas_scasum ;
-METHOD: Vasum { double-complex-blas-vector }
- (prepare-nrm2) cblas_dzasum ;
-
-METHOD: Viamax { float-blas-vector }
- (prepare-nrm2) cblas_isamax ;
-METHOD: Viamax { double-blas-vector }
- (prepare-nrm2) cblas_idamax ;
-METHOD: Viamax { float-complex-blas-vector }
- (prepare-nrm2) cblas_icamax ;
-METHOD: Viamax { double-complex-blas-vector }
- (prepare-nrm2) cblas_izamax ;
-
: Vamax ( x -- max )
[ Viamax ] keep nth ; inline
-: Vsub ( v start length -- sub )
- rot [
- [
- nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
- [ * * ] dip <displaced-alien>
- ] [ swap 2nip ] [ 2nip inc>> ] 3tri
- ] keep (blas-vector-like) ;
+:: Vsub ( v start length -- sub )
+ v inc>> start * v element-type heap-size *
+ v underlying>> <displaced-alien>
+ length v inc>> v (blas-vector-like) ;
+
+: <zero-vector> ( exemplar -- zero )
+ [ element-type <c-object> ]
+ [ length>> 0 ]
+ [ (blas-vector-like) ] tri ;
+
+: <empty-vector> ( length exemplar -- vector )
+ [ element-type <c-array> ]
+ [ 1 swap ] 2bi
+ (blas-vector-like) ;
+
+M: blas-vector-base equal?
+ {
+ [ [ length ] bi@ = ]
+ [ [ = ] 2all? ]
+ } 2&& ;
+
+M: blas-vector-base length
+ length>> ;
+M: blas-vector-base virtual-seq
+ (blas-direct-array) ;
+M: blas-vector-base virtual@
+ [ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
+
+
+<<
+
+FUNCTOR: (define-blas-vector) ( TYPE T -- )
+
+<DIRECT-ARRAY> IS <direct-${TYPE}-array>
+>ARRAY IS >${TYPE}-array
+XCOPY IS cblas_${T}copy
+XSWAP IS cblas_${T}swap
+XAXPY IS cblas_${T}axpy
+XSCAL IS cblas_${T}scal
+IXAMAX IS cblas_i${T}amax
+
+VECTOR DEFINES ${TYPE}-blas-vector
+<VECTOR> DEFINES <${TYPE}-blas-vector>
+>VECTOR DEFINES >${TYPE}-blas-vector
+
+WHERE
+
+TUPLE: VECTOR < blas-vector-base ;
+: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
+
+: >VECTOR ( seq -- v )
+ [ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
+
+M: VECTOR clone
+ TYPE heap-size (prepare-copy)
+ [ XCOPY execute ] 3dip <VECTOR> execute ;
+
+M: VECTOR element-type
+ drop TYPE ;
+M: VECTOR n*V+V!
+ (prepare-axpy) [ XAXPY execute ] dip ;
+M: VECTOR n*V!
+ (prepare-scal) [ XSCAL execute ] dip ;
+M: VECTOR Vswap
+ (prepare-swap) [ XSWAP execute ] 2dip ;
+M: VECTOR Viamax
+ (prepare-nrm2) IXAMAX execute ;
+
+M: VECTOR (blas-vector-like)
+ drop <VECTOR> execute ;
+
+M: VECTOR (blas-direct-array)
+ [ underlying>> ]
+ [ [ length>> ] [ inc>> ] bi * ] bi
+ <DIRECT-ARRAY> execute ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
+
+VECTOR IS ${TYPE}-blas-vector
+XDOT IS cblas_${T}dot
+XNRM2 IS cblas_${T}nrm2
+XASUM IS cblas_${T}asum
+
+WHERE
+
+M: VECTOR V.
+ (prepare-dot) XDOT execute ;
+M: VECTOR V.conj
+ (prepare-dot) XDOT execute ;
+M: VECTOR Vnorm
+ (prepare-nrm2) XNRM2 execute ;
+M: VECTOR Vasum
+ (prepare-nrm2) XASUM execute ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-complex-helpers) ( TYPE -- )
+
+<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
+>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
+ALIEN>COMPLEX DEFINES alien>${TYPE}-complex
+<DIRECT-ARRAY> IS <direct-${TYPE}-array>
+>ARRAY IS >${TYPE}-array
+
+WHERE
+
+: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
+ <DIRECT-ARRAY> execute <complex-sequence> ;
+: >COMPLEX-ARRAY ( sequence -- sequence )
+ <complex-components> >ARRAY execute ;
+: ALIEN>COMPLEX ( alien -- complex )
+ 2 <DIRECT-ARRAY> execute first2 rect> ;
+
+;FUNCTOR
+
+
+FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
+
+VECTOR IS ${TYPE}-blas-vector
+XDOTU_SUB IS cblas_${C}dotu_sub
+XDOTC_SUB IS cblas_${C}dotc_sub
+XXNRM2 IS cblas_${S}${C}nrm2
+XXASUM IS cblas_${S}${C}asum
+ALIEN>TYPE IS alien>${TYPE}
+
+WHERE
+
+M: VECTOR V.
+ (prepare-dot) TYPE <c-object>
+ [ XDOTU_SUB execute ] keep
+ ALIEN>TYPE execute ;
+M: VECTOR V.conj
+ (prepare-dot) TYPE <c-object>
+ [ XDOTC_SUB execute ] keep
+ ALIEN>TYPE execute ;
+M: VECTOR Vnorm
+ (prepare-nrm2) XXNRM2 execute ;
+M: VECTOR Vasum
+ (prepare-nrm2) XXASUM execute ;
+
+;FUNCTOR
+
+
+: define-real-blas-vector ( TYPE T -- )
+ [ (define-blas-vector) ]
+ [ (define-real-blas-vector) ] 2bi ;
+:: define-complex-blas-vector ( TYPE C S -- )
+ TYPE (define-complex-helpers)
+ TYPE "-complex" append
+ [ C (define-blas-vector) ]
+ [ C S (define-complex-blas-vector) ] bi
+ ;
+
+"float" "s" define-real-blas-vector
+"double" "d" define-real-blas-vector
+"float" "c" "s" define-complex-blas-vector
+"double" "z" "d" define-complex-blas-vector
+
+>>
+
diff --git a/extra/sequences/complex-components/authors.txt b/extra/sequences/complex-components/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/sequences/complex-components/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/sequences/complex-components/complex-components-docs.factor b/extra/sequences/complex-components/complex-components-docs.factor
new file mode 100644
index 0000000000..de1bed38a7
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components-docs.factor
@@ -0,0 +1,33 @@
+USING: help.markup help.syntax math multiline
+sequences sequences.complex-components ;
+IN: sequences.complex-components
+
+ARTICLE: "sequences.complex-components" "Complex component virtual sequences"
+"The " { $link complex-components } " class wraps a sequence of " { $link complex } " number values, presenting a sequence of " { $link real } " values made by interleaving the real and imaginary parts of the complex values in the original sequence."
+{ $subsection complex-components }
+{ $subsection <complex-components> } ;
+
+ABOUT: "sequences.complex-components"
+
+HELP: complex-components
+{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
+{ $examples { $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array
+"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
+
+HELP: <complex-components>
+{ $values { "sequence" sequence } { "complex-components" complex-components } }
+{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
+{ $examples
+{ $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third
+"> "-2.0" }
+{ $example <"
+USING: sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth
+"> "0" }
+} ;
+
+{ complex-components <complex-components> } related-words
diff --git a/extra/sequences/complex-components/complex-components-tests.factor b/extra/sequences/complex-components/complex-components-tests.factor
new file mode 100644
index 0000000000..f0c8e92c6e
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components-tests.factor
@@ -0,0 +1,16 @@
+USING: sequences.complex-components
+kernel sequences tools.test arrays accessors ;
+IN: sequences.complex-components.tests
+
+: test-array ( -- x )
+ { C{ 1.0 2.0 } 3.0 C{ 5.0 6.0 } } <complex-components> ;
+
+[ 6 ] [ test-array length ] unit-test
+
+[ 1.0 ] [ test-array first ] unit-test
+[ 2.0 ] [ test-array second ] unit-test
+[ 3.0 ] [ test-array third ] unit-test
+[ 0 ] [ test-array fourth ] unit-test
+
+[ { 1.0 2.0 3.0 0 5.0 6.0 } ] [ test-array >array ] unit-test
+
diff --git a/extra/sequences/complex-components/complex-components.factor b/extra/sequences/complex-components/complex-components.factor
new file mode 100644
index 0000000000..bca7e2c0a2
--- /dev/null
+++ b/extra/sequences/complex-components/complex-components.factor
@@ -0,0 +1,28 @@
+USING: accessors kernel math math.functions combinators
+sequences sequences.private ;
+IN: sequences.complex-components
+
+TUPLE: complex-components seq ;
+INSTANCE: complex-components sequence
+
+: <complex-components> ( sequence -- complex-sequence )
+ complex-components boa ; inline
+
+<PRIVATE
+
+: complex-components@ ( n seq -- remainder n' seq' )
+ [ [ 1 bitand ] [ -1 shift ] bi ] [ seq>> ] bi* ; inline
+: complex-component ( remainder complex -- component )
+ swap {
+ { 0 [ real-part ] }
+ { 1 [ imaginary-part ] }
+ } case ;
+
+PRIVATE>
+
+M: complex-components length
+ seq>> length 1 shift ;
+M: complex-components nth-unsafe
+ complex-components@ nth-unsafe complex-component ;
+M: complex-components set-nth-unsafe
+ immutable ;
diff --git a/extra/sequences/complex-components/summary.txt b/extra/sequences/complex-components/summary.txt
new file mode 100644
index 0000000000..af00158213
--- /dev/null
+++ b/extra/sequences/complex-components/summary.txt
@@ -0,0 +1 @@
+Virtual sequence wrapper to convert complex values into real value pairs
diff --git a/extra/sequences/complex-components/tags.txt b/extra/sequences/complex-components/tags.txt
new file mode 100644
index 0000000000..64cdcd9e69
--- /dev/null
+++ b/extra/sequences/complex-components/tags.txt
@@ -0,0 +1,2 @@
+sequences
+math
diff --git a/extra/sequences/complex/authors.txt b/extra/sequences/complex/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/sequences/complex/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/sequences/complex/complex-docs.factor b/extra/sequences/complex/complex-docs.factor
new file mode 100644
index 0000000000..d4d8dfc7a2
--- /dev/null
+++ b/extra/sequences/complex/complex-docs.factor
@@ -0,0 +1,29 @@
+USING: help.markup help.syntax math multiline
+sequences sequences.complex ;
+IN: sequences.complex
+
+ARTICLE: "sequences.complex" "Complex virtual sequences"
+"The " { $link complex-sequence } " class wraps a sequence of " { $link real } " number values, presenting a sequence of " { $link complex } " values made by treating the underlying sequence as pairs of alternating real and imaginary values."
+{ $subsection complex-sequence }
+{ $subsection <complex-sequence> } ;
+
+ABOUT: "sequences.complex"
+
+HELP: complex-sequence
+{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
+{ $examples { $example <"
+USING: specialized-arrays.double sequences.complex
+sequences arrays ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array
+"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
+
+HELP: <complex-sequence>
+{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
+{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
+{ $examples { $example <"
+USING: specialized-arrays.double sequences.complex
+sequences arrays ;
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second
+"> "C{ -2.0 2.0 }" } } ;
+
+{ complex-sequence <complex-sequence> } related-words
diff --git a/extra/sequences/complex/complex-tests.factor b/extra/sequences/complex/complex-tests.factor
new file mode 100644
index 0000000000..5861bc8b02
--- /dev/null
+++ b/extra/sequences/complex/complex-tests.factor
@@ -0,0 +1,26 @@
+USING: specialized-arrays.float sequences.complex
+kernel sequences tools.test arrays accessors ;
+IN: sequences.complex.tests
+
+: test-array ( -- x )
+ float-array{ 1.0 2.0 3.0 4.0 } clone <complex-sequence> ;
+: odd-length-test-array ( -- x )
+ float-array{ 1.0 2.0 3.0 4.0 5.0 } clone <complex-sequence> ;
+
+[ 2 ] [ test-array length ] unit-test
+[ 2 ] [ odd-length-test-array length ] unit-test
+
+[ C{ 1.0 2.0 } ] [ test-array first ] unit-test
+[ C{ 3.0 4.0 } ] [ test-array second ] unit-test
+
+[ { C{ 1.0 2.0 } C{ 3.0 4.0 } } ]
+[ test-array >array ] unit-test
+
+[ float-array{ 1.0 2.0 5.0 6.0 } ]
+[ test-array [ C{ 5.0 6.0 } 1 rot set-nth ] [ seq>> ] bi ]
+unit-test
+
+[ float-array{ 7.0 0.0 3.0 4.0 } ]
+[ test-array [ 7.0 0 rot set-nth ] [ seq>> ] bi ]
+unit-test
+
diff --git a/extra/sequences/complex/complex.factor b/extra/sequences/complex/complex.factor
new file mode 100644
index 0000000000..93f9727f75
--- /dev/null
+++ b/extra/sequences/complex/complex.factor
@@ -0,0 +1,25 @@
+USING: accessors kernel math math.functions
+sequences sequences.private ;
+IN: sequences.complex
+
+TUPLE: complex-sequence seq ;
+INSTANCE: complex-sequence sequence
+
+: <complex-sequence> ( sequence -- complex-sequence )
+ complex-sequence boa ; inline
+
+<PRIVATE
+
+: complex@ ( n seq -- n' seq' )
+ [ 1 shift ] [ seq>> ] bi* ; inline
+
+PRIVATE>
+
+M: complex-sequence length
+ seq>> length -1 shift ;
+M: complex-sequence nth-unsafe
+ complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ;
+M: complex-sequence set-nth-unsafe
+ complex@
+ [ [ real-part ] [ ] [ ] tri* set-nth-unsafe ]
+ [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ;
diff --git a/extra/sequences/complex/summary.txt b/extra/sequences/complex/summary.txt
new file mode 100644
index 0000000000..d94c4ba0f0
--- /dev/null
+++ b/extra/sequences/complex/summary.txt
@@ -0,0 +1 @@
+Virtual sequence wrapper to convert real pairs into complex values
diff --git a/extra/sequences/complex/tags.txt b/extra/sequences/complex/tags.txt
new file mode 100644
index 0000000000..64cdcd9e69
--- /dev/null
+++ b/extra/sequences/complex/tags.txt
@@ -0,0 +1,2 @@
+sequences
+math
From bd59b86ad64678976d0c67e8b24fdb492dc0e4e7 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 14:03:13 -0800
Subject: [PATCH 13/35] Fix complex blas vectors
---
extra/math/blas/vectors/vectors.factor | 29 ++++++++++++++++++--------
1 file changed, 20 insertions(+), 9 deletions(-)
diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index c229012370..56ec773c6a 100755
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -128,8 +128,6 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- )
>ARRAY IS >${TYPE}-array
XCOPY IS cblas_${T}copy
XSWAP IS cblas_${T}swap
-XAXPY IS cblas_${T}axpy
-XSCAL IS cblas_${T}scal
IXAMAX IS cblas_i${T}amax
VECTOR DEFINES ${TYPE}-blas-vector
@@ -150,10 +148,6 @@ M: VECTOR clone
M: VECTOR element-type
drop TYPE ;
-M: VECTOR n*V+V!
- (prepare-axpy) [ XAXPY execute ] dip ;
-M: VECTOR n*V!
- (prepare-scal) [ XSCAL execute ] dip ;
M: VECTOR Vswap
(prepare-swap) [ XSWAP execute ] 2dip ;
M: VECTOR Viamax
@@ -176,6 +170,8 @@ VECTOR IS ${TYPE}-blas-vector
XDOT IS cblas_${T}dot
XNRM2 IS cblas_${T}nrm2
XASUM IS cblas_${T}asum
+XAXPY IS cblas_${T}axpy
+XSCAL IS cblas_${T}scal
WHERE
@@ -187,6 +183,10 @@ M: VECTOR Vnorm
(prepare-nrm2) XNRM2 execute ;
M: VECTOR Vasum
(prepare-nrm2) XASUM execute ;
+M: VECTOR n*V+V!
+ (prepare-axpy) [ XAXPY execute ] dip ;
+M: VECTOR n*V!
+ (prepare-scal) [ XSCAL execute ] dip ;
;FUNCTOR
@@ -196,15 +196,18 @@ FUNCTOR: (define-complex-helpers) ( TYPE -- )
<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
ALIEN>COMPLEX DEFINES alien>${TYPE}-complex
+COMPLEX>ALIEN DEFINES ${TYPE}-complex>alien
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
WHERE
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
- <DIRECT-ARRAY> execute <complex-sequence> ;
+ 1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence )
<complex-components> >ARRAY execute ;
+: COMPLEX>ALIEN ( complex -- alien )
+ >rect 2array >ARRAY execute underlying>> ;
: ALIEN>COMPLEX ( alien -- complex )
2 <DIRECT-ARRAY> execute first2 rect> ;
@@ -218,6 +221,9 @@ XDOTU_SUB IS cblas_${C}dotu_sub
XDOTC_SUB IS cblas_${C}dotc_sub
XXNRM2 IS cblas_${S}${C}nrm2
XXASUM IS cblas_${S}${C}asum
+XAXPY IS cblas_${C}axpy
+XSCAL IS cblas_${C}scal
+TYPE>ALIEN IS ${TYPE}>alien
ALIEN>TYPE IS alien>${TYPE}
WHERE
@@ -234,6 +240,12 @@ M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 execute ;
M: VECTOR Vasum
(prepare-nrm2) XXASUM execute ;
+M: VECTOR n*V+V!
+ [ TYPE>ALIEN execute ] 2dip
+ (prepare-axpy) [ XAXPY execute ] dip ;
+M: VECTOR n*V!
+ [ TYPE>ALIEN execute ] dip
+ (prepare-scal) [ XSCAL execute ] dip ;
;FUNCTOR
@@ -245,8 +257,7 @@ M: VECTOR Vasum
TYPE (define-complex-helpers)
TYPE "-complex" append
[ C (define-blas-vector) ]
- [ C S (define-complex-blas-vector) ] bi
- ;
+ [ C S (define-complex-blas-vector) ] bi ;
"float" "s" define-real-blas-vector
"double" "d" define-real-blas-vector
From ec76a0bfffa8ba47740e36901f8dd1a7f11bc846 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 16:08:01 -0800
Subject: [PATCH 14/35] Renovate BLAS matrices
---
extra/math/blas/matrices/matrices-docs.factor | 2 +-
extra/math/blas/matrices/matrices.factor | 273 +++++++++---------
extra/math/blas/syntax/syntax.factor | 26 +-
extra/math/blas/vectors/vectors.factor | 24 +-
4 files changed, 167 insertions(+), 158 deletions(-)
diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor
index dc6a86017a..01e0997405 100644
--- a/extra/math/blas/matrices/matrices-docs.factor
+++ b/extra/math/blas/matrices/matrices-docs.factor
@@ -88,7 +88,7 @@ HELP: blas-matrix-base
}
"All of these subclasses share the same tuple layout:"
{ $list
- { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
+ { { $snippet "underlying" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" }
{ { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" }
{ { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" }
{ "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." }
diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor
index 0899e2d079..c8a4ee6292 100755
--- a/extra/math/blas/matrices/matrices.factor
+++ b/extra/math/blas/matrices/matrices.factor
@@ -1,31 +1,13 @@
USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.lib combinators.short-circuit fry kernel locals macros
+combinators.short-circuit fry kernel locals macros
math math.blas.cblas math.blas.vectors math.blas.vectors.private
-math.complex math.functions math.order multi-methods qualified
-sequences sequences.merged sequences.private generalizations
-shuffle symbols speicalized-arrays.float specialized-arrays.double ;
-QUALIFIED: syntax
+math.complex math.functions math.order functors words
+sequences sequences.merged sequences.private shuffle symbols
+specialized-arrays.direct.float specialized-arrays.direct.double
+specialized-arrays.float specialized-arrays.double ;
IN: math.blas.matrices
-TUPLE: blas-matrix-base data ld rows cols transpose ;
-TUPLE: float-blas-matrix < blas-matrix-base ;
-TUPLE: double-blas-matrix < blas-matrix-base ;
-TUPLE: float-complex-blas-matrix < blas-matrix-base ;
-TUPLE: double-complex-blas-matrix < blas-matrix-base ;
-
-C: <float-blas-matrix> float-blas-matrix
-C: <double-blas-matrix> double-blas-matrix
-C: <float-complex-blas-matrix> float-complex-blas-matrix
-C: <double-complex-blas-matrix> double-complex-blas-matrix
-
-METHOD: element-type { float-blas-matrix }
- drop "float" ;
-METHOD: element-type { double-blas-matrix }
- drop "double" ;
-METHOD: element-type { float-complex-blas-matrix }
- drop "CBLAS_C" ;
-METHOD: element-type { double-complex-blas-matrix }
- drop "CBLAS_Z" ;
+TUPLE: blas-matrix-base underlying ld rows cols transpose ;
: Mtransposed? ( matrix -- ? )
transpose>> ; inline
@@ -34,6 +16,11 @@ METHOD: element-type { double-complex-blas-matrix }
: Mheight ( matrix -- height )
dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline
+GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
+GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
+GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
+GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
+
<PRIVATE
: (blas-transpose) ( matrix -- integer )
@@ -41,53 +28,29 @@ METHOD: element-type { double-complex-blas-matrix }
GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
-METHOD: (blas-matrix-like) { object object object object object float-blas-matrix }
- drop <float-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-blas-matrix }
- drop <double-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix }
- drop <float-complex-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix }
- drop <double-complex-blas-matrix> ;
-
-METHOD: (blas-matrix-like) { object object object object object float-blas-vector }
- drop <float-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-blas-vector }
- drop <double-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector }
- drop <float-complex-blas-matrix> ;
-METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector }
- drop <double-complex-blas-matrix> ;
-
-METHOD: (blas-vector-like) { object object object float-blas-matrix }
- drop <float-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-blas-matrix }
- drop <double-blas-vector> ;
-METHOD: (blas-vector-like) { object object object float-complex-blas-matrix }
- drop <float-complex-blas-vector> ;
-METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
- drop <double-complex-blas-vector> ;
-
: (validate-gemv) ( A x y -- )
{
[ drop [ Mwidth ] [ length>> ] bi* = ]
[ nip [ Mheight ] [ length>> ] bi* = ]
} 3&&
- [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] unless ;
+ [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ]
+ unless ;
-:: (prepare-gemv) ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc y )
+:: (prepare-gemv)
+ ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
+ y )
A x y (validate-gemv)
CblasColMajor
A (blas-transpose)
A rows>>
A cols>>
alpha >c-arg call
- A data>>
+ A underlying>>
A ld>>
- x data>>
+ x underlying>>
x inc>>
beta >c-arg call
- y data>>
+ y underlying>>
y inc>>
y ; inline
@@ -96,19 +59,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
[ nip [ length>> ] [ Mheight ] bi* = ]
[ nipd [ length>> ] [ Mwidth ] bi* = ]
} 3&&
- [ "Mismatched vertices and matrix in vector outer product" throw ] unless ;
+ [ "Mismatched vertices and matrix in vector outer product" throw ]
+ unless ;
-:: (prepare-ger) ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld A )
+:: (prepare-ger)
+ ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld
+ A )
x y A (validate-ger)
CblasColMajor
A rows>>
A cols>>
alpha >c-arg call
- x data>>
+ x underlying>>
x inc>>
- y data>>
+ y underlying>>
y inc>>
- A data>>
+ A underlying>>
A ld>>
A f >>transpose ; inline
@@ -117,9 +83,13 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
[ drop [ Mwidth ] [ Mheight ] bi* = ]
[ nip [ Mheight ] bi@ = ]
[ nipd [ Mwidth ] bi@ = ]
- } 3&& [ "Mismatched matrices in matrix multiplication" throw ] unless ;
+ } 3&&
+ [ "Mismatched matrices in matrix multiplication" throw ]
+ unless ;
-:: (prepare-gemm) ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld C )
+:: (prepare-gemm)
+ ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
+ C )
A B C (validate-gemm)
CblasColMajor
A (blas-transpose)
@@ -128,12 +98,12 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
C cols>>
A Mwidth
alpha >c-arg call
- A data>>
+ A underlying>>
A ld>>
- B data>>
+ B underlying>>
B ld>>
beta >c-arg call
- C data>>
+ C underlying>>
C ld>>
C f >>transpose ; inline
@@ -142,65 +112,22 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix }
PRIVATE>
-: >float-blas-matrix ( arrays -- matrix )
- [ >float-array underlying>> ] (>matrix) <float-blas-matrix> ;
-: >double-blas-matrix ( arrays -- matrix )
- [ >double-array underlying>> ] (>matrix) <double-blas-matrix> ;
-: >float-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >float-array underlying>> ] (>matrix)
- <float-complex-blas-matrix> ;
-: >double-complex-blas-matrix ( arrays -- matrix )
- [ (flatten-complex-sequence) >double-array underlying>> ] (>matrix)
- <double-complex-blas-matrix> ;
-
-GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
-GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
-GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
-GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C )
-
-METHOD: n*M.V+n*V! { real float-blas-matrix float-blas-vector real float-blas-vector }
- [ ] (prepare-gemv) [ cblas_sgemv ] dip ;
-METHOD: n*M.V+n*V! { real double-blas-matrix double-blas-vector real double-blas-vector }
- [ ] (prepare-gemv) [ cblas_dgemv ] dip ;
-METHOD: n*M.V+n*V! { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector }
- [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ;
-METHOD: n*M.V+n*V! { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector }
- [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ;
-
-METHOD: n*V(*)V+M! { real float-blas-vector float-blas-vector float-blas-matrix }
- [ ] (prepare-ger) [ cblas_sger ] dip ;
-METHOD: n*V(*)V+M! { real double-blas-vector double-blas-vector double-blas-matrix }
- [ ] (prepare-ger) [ cblas_dger ] dip ;
-METHOD: n*V(*)V+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ;
-METHOD: n*V(*)V+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ;
-
-METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
- [ ] (prepare-ger) [ cblas_sger ] dip ;
-METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
- [ ] (prepare-ger) [ cblas_dger ] dip ;
-METHOD: n*V(*)Vconj+M! { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ;
-METHOD: n*V(*)Vconj+M! { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ;
-
-METHOD: n*M.M+n*M! { real float-blas-matrix float-blas-matrix real float-blas-matrix }
- [ ] (prepare-gemm) [ cblas_sgemm ] dip ;
-METHOD: n*M.M+n*M! { real double-blas-matrix double-blas-matrix real double-blas-matrix }
- [ ] (prepare-gemm) [ cblas_dgemm ] dip ;
-METHOD: n*M.M+n*M! { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix }
- [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ;
-METHOD: n*M.M+n*M! { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix }
- [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ;
-
! XXX should do a dense clone
-syntax:M: blas-matrix-base clone
+M: blas-matrix-base clone
[
- [
- { [ data>> ] [ ld>> ] [ cols>> ] [ element-type heap-size ] } cleave
- * * memory>byte-array
- ] [ { [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> ] } cleave ] bi
+ [ {
+ [ underlying>> ]
+ [ ld>> ]
+ [ cols>> ]
+ [ element-type heap-size ]
+ } cleave * * memory>byte-array ]
+ [ {
+ [ ld>> ]
+ [ rows>> ]
+ [ cols>> ]
+ [ transpose>> ]
+ } cleave ]
+ bi
] keep (blas-matrix-like) ;
! XXX try rounding stride to next 128 bit bound for better vectorizin'
@@ -246,29 +173,31 @@ syntax:M: blas-matrix-base clone
:: (Msub) ( matrix row col height width -- data ld rows cols )
matrix ld>> col * row + matrix element-type heap-size *
- matrix data>> <displaced-alien>
+ matrix underlying>> <displaced-alien>
matrix ld>>
height
width ;
-: Msub ( matrix row col height width -- sub )
- 5 npick dup transpose>>
- [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
- swap (blas-matrix-like) ;
+:: Msub ( matrix row col height width -- sub )
+ matrix dup transpose>>
+ [ col row width height ]
+ [ row col height width ] if (Msub)
+ matrix transpose>> matrix (blas-matrix-like) ;
-TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ;
+TUPLE: blas-matrix-rowcol-sequence
+ parent inc rowcol-length rowcol-jump length ;
C: <blas-matrix-rowcol-sequence> blas-matrix-rowcol-sequence
INSTANCE: blas-matrix-rowcol-sequence sequence
-syntax:M: blas-matrix-rowcol-sequence length
+M: blas-matrix-rowcol-sequence length
length>> ;
-syntax:M: blas-matrix-rowcol-sequence nth-unsafe
+M: blas-matrix-rowcol-sequence nth-unsafe
{
[
[ rowcol-jump>> ]
[ parent>> element-type heap-size ]
- [ parent>> data>> ] tri
+ [ parent>> underlying>> ] tri
[ * * ] dip <displaced-alien>
]
[ rowcol-length>> ]
@@ -277,11 +206,11 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
} cleave (blas-vector-like) ;
: (Mcols) ( A -- columns )
- { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave
- <blas-matrix-rowcol-sequence> ;
+ { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] }
+ cleave <blas-matrix-rowcol-sequence> ;
: (Mrows) ( A -- rows )
- { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave
- <blas-matrix-rowcol-sequence> ;
+ { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] }
+ cleave <blas-matrix-rowcol-sequence> ;
: Mrows ( A -- rows )
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
@@ -300,11 +229,79 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
recip swap n*M ; inline
: Mtranspose ( matrix -- matrix^T )
- [ { [ data>> ] [ ld>> ] [ rows>> ] [ cols>> ] [ transpose>> not ] } cleave ] keep (blas-matrix-like) ;
+ [ {
+ [ underlying>> ]
+ [ ld>> ] [ rows>> ]
+ [ cols>> ]
+ [ transpose>> not ]
+ } cleave ] keep (blas-matrix-like) ;
-syntax:M: blas-matrix-base equal?
+M: blas-matrix-base equal?
{
[ [ Mwidth ] bi@ = ]
[ [ Mcols ] bi@ [ = ] 2all? ]
} 2&& ;
+<<
+
+FUNCTOR: (define-blas-matrix) ( TYPE T U C -- )
+
+VECTOR IS ${TYPE}-blas-vector
+<VECTOR> IS <${TYPE}-blas-vector>
+>ARRAY IS >${TYPE}-array
+TYPE>ARG IS ${TYPE}>arg
+XGEMV IS cblas_${T}gemv
+XGEMM IS cblas_${T}gemm
+XGERU IS cblas_${T}ger${U}
+XGERC IS cblas_${T}ger${C}
+
+MATRIX DEFINES ${TYPE}-blas-matrix
+<MATRIX> DEFINES <${TYPE}-blas-matrix>
+>MATRIX DEFINES >${TYPE}-blas-matrix
+
+WHERE
+
+TUPLE: MATRIX < blas-matrix-base ;
+: <MATRIX> ( underlying ld rows cols transpose -- matrix )
+ MATRIX boa ; inline
+
+M: MATRIX element-type
+ drop TYPE ;
+M: MATRIX (blas-matrix-like)
+ drop <MATRIX> execute ;
+M: VECTOR (blas-matrix-like)
+ drop <MATRIX> execute ;
+M: MATRIX (blas-vector-like)
+ drop <VECTOR> execute ;
+
+: >MATRIX ( arrays -- matrix )
+ [ >ARRAY execute underlying>> ] (>matrix)
+ <MATRIX> execute ;
+
+M: VECTOR n*M.V+n*V!
+ [ TYPE>ARG execute ] (prepare-gemv)
+ [ XGEMV execute ] dip ;
+M: MATRIX n*M.M+n*M!
+ [ TYPE>ARG execute ] (prepare-gemm)
+ [ XGEMM execute ] dip ;
+M: MATRIX n*V(*)V+M!
+ [ TYPE>ARG execute ] (prepare-ger)
+ [ XGERU execute ] dip ;
+M: MATRIX n*V(*)Vconj+M!
+ [ TYPE>ARG execute ] (prepare-ger)
+ [ XGERC execute ] dip ;
+
+;FUNCTOR
+
+
+: define-real-blas-matrix ( TYPE T -- )
+ "" "" (define-blas-matrix) ;
+: define-complex-blas-matrix ( TYPE T -- )
+ "u" "c" (define-blas-matrix) ;
+
+"float" "s" define-real-blas-matrix
+"double" "d" define-real-blas-matrix
+"float-complex" "c" define-complex-blas-matrix
+"double-complex" "z" define-complex-blas-matrix
+
+>>
diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor
index 6b40910687..95f9f7bd08 100644
--- a/extra/math/blas/syntax/syntax.factor
+++ b/extra/math/blas/syntax/syntax.factor
@@ -1,4 +1,4 @@
-USING: kernel math.blas.matrices math.blas.vectors parser
+USING: kernel math.blas.vectors math.blas.matrices parser
arrays prettyprint.backend sequences ;
IN: math.blas.syntax
@@ -20,15 +20,23 @@ IN: math.blas.syntax
: zmatrix{
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
-M: float-blas-vector pprint-delims drop \ svector{ \ } ;
-M: double-blas-vector pprint-delims drop \ dvector{ \ } ;
-M: float-complex-blas-vector pprint-delims drop \ cvector{ \ } ;
-M: double-complex-blas-vector pprint-delims drop \ zvector{ \ } ;
+M: float-blas-vector pprint-delims
+ drop \ svector{ \ } ;
+M: double-blas-vector pprint-delims
+ drop \ dvector{ \ } ;
+M: float-complex-blas-vector pprint-delims
+ drop \ cvector{ \ } ;
+M: double-complex-blas-vector pprint-delims
+ drop \ zvector{ \ } ;
-M: float-blas-matrix pprint-delims drop \ smatrix{ \ } ;
-M: double-blas-matrix pprint-delims drop \ dmatrix{ \ } ;
-M: float-complex-blas-matrix pprint-delims drop \ cmatrix{ \ } ;
-M: double-complex-blas-matrix pprint-delims drop \ zmatrix{ \ } ;
+M: float-blas-matrix pprint-delims
+ drop \ smatrix{ \ } ;
+M: double-blas-matrix pprint-delims
+ drop \ dmatrix{ \ } ;
+M: float-complex-blas-matrix pprint-delims
+ drop \ cmatrix{ \ } ;
+M: double-complex-blas-matrix pprint-delims
+ drop \ zmatrix{ \ } ;
M: blas-vector-base >pprint-sequence ;
M: blas-vector-base pprint* pprint-object ;
diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index 56ec773c6a..41fe2b4740 100755
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -119,6 +119,10 @@ M: blas-vector-base virtual-seq
M: blas-vector-base virtual@
[ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
+: float>arg ( f -- f ) ; inline
+: double>arg ( f -- f ) ; inline
+: arg>float ( f -- f ) ; inline
+: arg>double ( f -- f ) ; inline
<<
@@ -195,8 +199,8 @@ FUNCTOR: (define-complex-helpers) ( TYPE -- )
<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
>COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
-ALIEN>COMPLEX DEFINES alien>${TYPE}-complex
-COMPLEX>ALIEN DEFINES ${TYPE}-complex>alien
+ARG>COMPLEX DEFINES arg>${TYPE}-complex
+COMPLEX>ARG DEFINES ${TYPE}-complex>arg
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
@@ -206,9 +210,9 @@ WHERE
1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
: >COMPLEX-ARRAY ( sequence -- sequence )
<complex-components> >ARRAY execute ;
-: COMPLEX>ALIEN ( complex -- alien )
+: COMPLEX>ARG ( complex -- alien )
>rect 2array >ARRAY execute underlying>> ;
-: ALIEN>COMPLEX ( alien -- complex )
+: ARG>COMPLEX ( alien -- complex )
2 <DIRECT-ARRAY> execute first2 rect> ;
;FUNCTOR
@@ -223,28 +227,28 @@ XXNRM2 IS cblas_${S}${C}nrm2
XXASUM IS cblas_${S}${C}asum
XAXPY IS cblas_${C}axpy
XSCAL IS cblas_${C}scal
-TYPE>ALIEN IS ${TYPE}>alien
-ALIEN>TYPE IS alien>${TYPE}
+TYPE>ARG IS ${TYPE}>arg
+ARG>TYPE IS arg>${TYPE}
WHERE
M: VECTOR V.
(prepare-dot) TYPE <c-object>
[ XDOTU_SUB execute ] keep
- ALIEN>TYPE execute ;
+ ARG>TYPE execute ;
M: VECTOR V.conj
(prepare-dot) TYPE <c-object>
[ XDOTC_SUB execute ] keep
- ALIEN>TYPE execute ;
+ ARG>TYPE execute ;
M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 execute ;
M: VECTOR Vasum
(prepare-nrm2) XXASUM execute ;
M: VECTOR n*V+V!
- [ TYPE>ALIEN execute ] 2dip
+ [ TYPE>ARG execute ] 2dip
(prepare-axpy) [ XAXPY execute ] dip ;
M: VECTOR n*V!
- [ TYPE>ALIEN execute ] dip
+ [ TYPE>ARG execute ] dip
(prepare-scal) [ XSCAL execute ] dip ;
;FUNCTOR
From c73fd625edf8afe080f69291489dade004da6b1e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 16:15:42 -0800
Subject: [PATCH 15/35] remove "generalizations" use from math.blas.vectors
---
extra/math/blas/vectors/vectors.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index 41fe2b4740..db027b0ffd 100755
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel math math.blas.cblas
math.complex math.functions math.order sequences.complex
sequences.complex-components sequences sequences.private
-generalizations functors words locals
+functors words locals
specialized-arrays.float specialized-arrays.double
specialized-arrays.direct.float specialized-arrays.direct.double ;
IN: math.blas.vectors
From bec5b76eeaed54365c36ea97c6761da0af5885bb Mon Sep 17 00:00:00 2001
From: "U-VICTORIA\\Administrator" <Administrator@victoria.(none)>
Date: Thu, 4 Dec 2008 17:05:13 -0800
Subject: [PATCH 16/35] move opengl libs back to extra
---
{unmaintained => extra}/opengl/capabilities/authors.txt | 0
.../opengl/capabilities/capabilities-docs.factor | 0
{unmaintained => extra}/opengl/capabilities/capabilities.factor | 0
{unmaintained => extra}/opengl/capabilities/summary.txt | 0
{unmaintained => extra}/opengl/capabilities/tags.txt | 0
{unmaintained => extra}/opengl/demo-support/authors.txt | 0
{unmaintained => extra}/opengl/demo-support/demo-support.factor | 0
{unmaintained => extra}/opengl/demo-support/summary.txt | 0
{unmaintained => extra}/opengl/demo-support/tags.txt | 0
{unmaintained => extra}/opengl/framebuffers/authors.txt | 0
.../opengl/framebuffers/framebuffers-docs.factor | 0
{unmaintained => extra}/opengl/framebuffers/framebuffers.factor | 0
{unmaintained => extra}/opengl/framebuffers/summary.txt | 0
{unmaintained => extra}/opengl/framebuffers/tags.txt | 0
{unmaintained => extra}/opengl/gadgets/gadgets-tests.factor | 0
{unmaintained => extra}/opengl/gadgets/gadgets.factor | 0
{unmaintained => extra}/opengl/shaders/authors.txt | 0
{unmaintained => extra}/opengl/shaders/shaders-docs.factor | 0
{unmaintained => extra}/opengl/shaders/shaders.factor | 0
{unmaintained => extra}/opengl/shaders/summary.txt | 0
{unmaintained => extra}/opengl/shaders/tags.txt | 0
21 files changed, 0 insertions(+), 0 deletions(-)
rename {unmaintained => extra}/opengl/capabilities/authors.txt (100%)
rename {unmaintained => extra}/opengl/capabilities/capabilities-docs.factor (100%)
rename {unmaintained => extra}/opengl/capabilities/capabilities.factor (100%)
rename {unmaintained => extra}/opengl/capabilities/summary.txt (100%)
rename {unmaintained => extra}/opengl/capabilities/tags.txt (100%)
rename {unmaintained => extra}/opengl/demo-support/authors.txt (100%)
rename {unmaintained => extra}/opengl/demo-support/demo-support.factor (100%)
rename {unmaintained => extra}/opengl/demo-support/summary.txt (100%)
rename {unmaintained => extra}/opengl/demo-support/tags.txt (100%)
rename {unmaintained => extra}/opengl/framebuffers/authors.txt (100%)
rename {unmaintained => extra}/opengl/framebuffers/framebuffers-docs.factor (100%)
rename {unmaintained => extra}/opengl/framebuffers/framebuffers.factor (100%)
rename {unmaintained => extra}/opengl/framebuffers/summary.txt (100%)
rename {unmaintained => extra}/opengl/framebuffers/tags.txt (100%)
rename {unmaintained => extra}/opengl/gadgets/gadgets-tests.factor (100%)
rename {unmaintained => extra}/opengl/gadgets/gadgets.factor (100%)
rename {unmaintained => extra}/opengl/shaders/authors.txt (100%)
rename {unmaintained => extra}/opengl/shaders/shaders-docs.factor (100%)
rename {unmaintained => extra}/opengl/shaders/shaders.factor (100%)
rename {unmaintained => extra}/opengl/shaders/summary.txt (100%)
rename {unmaintained => extra}/opengl/shaders/tags.txt (100%)
diff --git a/unmaintained/opengl/capabilities/authors.txt b/extra/opengl/capabilities/authors.txt
similarity index 100%
rename from unmaintained/opengl/capabilities/authors.txt
rename to extra/opengl/capabilities/authors.txt
diff --git a/unmaintained/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor
similarity index 100%
rename from unmaintained/opengl/capabilities/capabilities-docs.factor
rename to extra/opengl/capabilities/capabilities-docs.factor
diff --git a/unmaintained/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor
similarity index 100%
rename from unmaintained/opengl/capabilities/capabilities.factor
rename to extra/opengl/capabilities/capabilities.factor
diff --git a/unmaintained/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt
similarity index 100%
rename from unmaintained/opengl/capabilities/summary.txt
rename to extra/opengl/capabilities/summary.txt
diff --git a/unmaintained/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt
similarity index 100%
rename from unmaintained/opengl/capabilities/tags.txt
rename to extra/opengl/capabilities/tags.txt
diff --git a/unmaintained/opengl/demo-support/authors.txt b/extra/opengl/demo-support/authors.txt
similarity index 100%
rename from unmaintained/opengl/demo-support/authors.txt
rename to extra/opengl/demo-support/authors.txt
diff --git a/unmaintained/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
similarity index 100%
rename from unmaintained/opengl/demo-support/demo-support.factor
rename to extra/opengl/demo-support/demo-support.factor
diff --git a/unmaintained/opengl/demo-support/summary.txt b/extra/opengl/demo-support/summary.txt
similarity index 100%
rename from unmaintained/opengl/demo-support/summary.txt
rename to extra/opengl/demo-support/summary.txt
diff --git a/unmaintained/opengl/demo-support/tags.txt b/extra/opengl/demo-support/tags.txt
similarity index 100%
rename from unmaintained/opengl/demo-support/tags.txt
rename to extra/opengl/demo-support/tags.txt
diff --git a/unmaintained/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt
similarity index 100%
rename from unmaintained/opengl/framebuffers/authors.txt
rename to extra/opengl/framebuffers/authors.txt
diff --git a/unmaintained/opengl/framebuffers/framebuffers-docs.factor b/extra/opengl/framebuffers/framebuffers-docs.factor
similarity index 100%
rename from unmaintained/opengl/framebuffers/framebuffers-docs.factor
rename to extra/opengl/framebuffers/framebuffers-docs.factor
diff --git a/unmaintained/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor
similarity index 100%
rename from unmaintained/opengl/framebuffers/framebuffers.factor
rename to extra/opengl/framebuffers/framebuffers.factor
diff --git a/unmaintained/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt
similarity index 100%
rename from unmaintained/opengl/framebuffers/summary.txt
rename to extra/opengl/framebuffers/summary.txt
diff --git a/unmaintained/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt
similarity index 100%
rename from unmaintained/opengl/framebuffers/tags.txt
rename to extra/opengl/framebuffers/tags.txt
diff --git a/unmaintained/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor
similarity index 100%
rename from unmaintained/opengl/gadgets/gadgets-tests.factor
rename to extra/opengl/gadgets/gadgets-tests.factor
diff --git a/unmaintained/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor
similarity index 100%
rename from unmaintained/opengl/gadgets/gadgets.factor
rename to extra/opengl/gadgets/gadgets.factor
diff --git a/unmaintained/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt
similarity index 100%
rename from unmaintained/opengl/shaders/authors.txt
rename to extra/opengl/shaders/authors.txt
diff --git a/unmaintained/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor
similarity index 100%
rename from unmaintained/opengl/shaders/shaders-docs.factor
rename to extra/opengl/shaders/shaders-docs.factor
diff --git a/unmaintained/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
similarity index 100%
rename from unmaintained/opengl/shaders/shaders.factor
rename to extra/opengl/shaders/shaders.factor
diff --git a/unmaintained/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt
similarity index 100%
rename from unmaintained/opengl/shaders/summary.txt
rename to extra/opengl/shaders/summary.txt
diff --git a/unmaintained/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt
similarity index 100%
rename from unmaintained/opengl/shaders/tags.txt
rename to extra/opengl/shaders/tags.txt
From a67de2289ad19b5e003e716b792d6149b9e40391 Mon Sep 17 00:00:00 2001
From: "U-VICTORIA\\Administrator" <Administrator@victoria.(none)>
Date: Thu, 4 Dec 2008 18:18:19 -0800
Subject: [PATCH 17/35] snipe some bunny bugs
---
{unmaintained => extra}/bunny/authors.txt | 0
{unmaintained => extra}/bunny/bun_zipper.ply | 0
{unmaintained => extra}/bunny/bunny.factor | 0
.../bunny/cel-shaded/cel-shaded.factor | 0
{unmaintained => extra}/bunny/deploy.factor | 0
.../bunny/fixed-pipeline/fixed-pipeline.factor | 3 ++-
{unmaintained => extra}/bunny/model/model.factor | 4 ++--
{unmaintained => extra}/bunny/outlined/outlined.factor | 0
{unmaintained => extra}/bunny/summary.txt | 0
{unmaintained => extra}/bunny/tags.txt | 0
extra/opengl/shaders/shaders.factor | 9 +++++----
{unmaintained => extra}/spheres/authors.txt | 0
{unmaintained => extra}/spheres/deploy.factor | 0
{unmaintained => extra}/spheres/spheres.factor | 0
{unmaintained => extra}/spheres/summary.txt | 0
{unmaintained => extra}/spheres/tags.txt | 0
16 files changed, 9 insertions(+), 7 deletions(-)
rename {unmaintained => extra}/bunny/authors.txt (100%)
rename {unmaintained => extra}/bunny/bun_zipper.ply (100%)
rename {unmaintained => extra}/bunny/bunny.factor (100%)
rename {unmaintained => extra}/bunny/cel-shaded/cel-shaded.factor (100%)
rename {unmaintained => extra}/bunny/deploy.factor (100%)
rename {unmaintained => extra}/bunny/fixed-pipeline/fixed-pipeline.factor (90%)
mode change 100644 => 100755
rename {unmaintained => extra}/bunny/model/model.factor (96%)
rename {unmaintained => extra}/bunny/outlined/outlined.factor (100%)
rename {unmaintained => extra}/bunny/summary.txt (100%)
rename {unmaintained => extra}/bunny/tags.txt (100%)
rename {unmaintained => extra}/spheres/authors.txt (100%)
rename {unmaintained => extra}/spheres/deploy.factor (100%)
rename {unmaintained => extra}/spheres/spheres.factor (100%)
rename {unmaintained => extra}/spheres/summary.txt (100%)
rename {unmaintained => extra}/spheres/tags.txt (100%)
diff --git a/unmaintained/bunny/authors.txt b/extra/bunny/authors.txt
similarity index 100%
rename from unmaintained/bunny/authors.txt
rename to extra/bunny/authors.txt
diff --git a/unmaintained/bunny/bun_zipper.ply b/extra/bunny/bun_zipper.ply
similarity index 100%
rename from unmaintained/bunny/bun_zipper.ply
rename to extra/bunny/bun_zipper.ply
diff --git a/unmaintained/bunny/bunny.factor b/extra/bunny/bunny.factor
similarity index 100%
rename from unmaintained/bunny/bunny.factor
rename to extra/bunny/bunny.factor
diff --git a/unmaintained/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
similarity index 100%
rename from unmaintained/bunny/cel-shaded/cel-shaded.factor
rename to extra/bunny/cel-shaded/cel-shaded.factor
diff --git a/unmaintained/bunny/deploy.factor b/extra/bunny/deploy.factor
similarity index 100%
rename from unmaintained/bunny/deploy.factor
rename to extra/bunny/deploy.factor
diff --git a/unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
old mode 100644
new mode 100755
similarity index 90%
rename from unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor
rename to extra/bunny/fixed-pipeline/fixed-pipeline.factor
index fd420d0b7d..0791773ba7
--- a/unmaintained/bunny/fixed-pipeline/fixed-pipeline.factor
+++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
@@ -1,5 +1,6 @@
USING: alien.c-types continuations destructors kernel
-opengl opengl.gl bunny.model specialized-arrays.float ;
+opengl opengl.gl bunny.model specialized-arrays.float
+accessors ;
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;
diff --git a/unmaintained/bunny/model/model.factor b/extra/bunny/model/model.factor
similarity index 96%
rename from unmaintained/bunny/model/model.factor
rename to extra/bunny/model/model.factor
index c9d109cb71..452adf5689 100755
--- a/unmaintained/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -3,7 +3,7 @@ http.client io io.encodings.ascii io.files kernel math
math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
sequences.lib splitting vectors words
-specialized-arrays.double specialized-arrays.uint ;
+specialized-arrays.float specialized-arrays.uint ;
IN: bunny.model
: numbers ( str -- seq )
@@ -66,7 +66,7 @@ TUPLE: bunny-buffers array element-array nv ni ;
{
[
[ first concat ] [ second concat ] bi
- append >double-array underlying>>
+ append >float-array underlying>>
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[
diff --git a/unmaintained/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
similarity index 100%
rename from unmaintained/bunny/outlined/outlined.factor
rename to extra/bunny/outlined/outlined.factor
diff --git a/unmaintained/bunny/summary.txt b/extra/bunny/summary.txt
similarity index 100%
rename from unmaintained/bunny/summary.txt
rename to extra/bunny/summary.txt
diff --git a/unmaintained/bunny/tags.txt b/extra/bunny/tags.txt
similarity index 100%
rename from unmaintained/bunny/tags.txt
rename to extra/bunny/tags.txt
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
index a88ea6de4d..476bb1be71 100755
--- a/extra/opengl/shaders/shaders.factor
+++ b/extra/opengl/shaders/shaders.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii fry ;
+combinators.lib macros arrays io.encodings.ascii fry
+specialized-arrays.uint destructors accessors ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@@ -93,9 +94,9 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length
- dup <uint-array>
- 0 <int> swap
- [ underlying>> glGetAttachedShaders ] { 3 1 } multikeep ;
+ 0 <int>
+ over <uint-array>
+ [ underlying>> glGetAttachedShaders ] keep ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline
diff --git a/unmaintained/spheres/authors.txt b/extra/spheres/authors.txt
similarity index 100%
rename from unmaintained/spheres/authors.txt
rename to extra/spheres/authors.txt
diff --git a/unmaintained/spheres/deploy.factor b/extra/spheres/deploy.factor
similarity index 100%
rename from unmaintained/spheres/deploy.factor
rename to extra/spheres/deploy.factor
diff --git a/unmaintained/spheres/spheres.factor b/extra/spheres/spheres.factor
similarity index 100%
rename from unmaintained/spheres/spheres.factor
rename to extra/spheres/spheres.factor
diff --git a/unmaintained/spheres/summary.txt b/extra/spheres/summary.txt
similarity index 100%
rename from unmaintained/spheres/summary.txt
rename to extra/spheres/summary.txt
diff --git a/unmaintained/spheres/tags.txt b/extra/spheres/tags.txt
similarity index 100%
rename from unmaintained/spheres/tags.txt
rename to extra/spheres/tags.txt
From 1443e6689710cb5a9a3e864eb96a4124a87d2253 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 18:31:31 -0800
Subject: [PATCH 18/35] bring back classic Amiga colors for spheres
---
extra/spheres/spheres.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index 826c66851e..7a0c0d2e77 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -225,8 +225,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
plane-program>> [
{
[ "checker_size_inv" glGetUniformLocation 0.125 glUniform1f ]
- [ "checker_color_1" glGetUniformLocation 1.0 0.5 0.0 1.0 glUniform4f ]
- [ "checker_color_2" glGetUniformLocation 0.0 0.0 0.0 1.0 glUniform4f ]
+ [ "checker_color_1" glGetUniformLocation 1.0 0.0 0.0 1.0 glUniform4f ]
+ [ "checker_color_2" glGetUniformLocation 1.0 1.0 1.0 1.0 glUniform4f ]
} cleave
GL_QUADS [
-1000.0 -30.0 1000.0 glVertex3f
From c3ca5a819178218d021b595ac1e9d7a4acb7981c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 4 Dec 2008 18:47:18 -0800
Subject: [PATCH 19/35] i fail at documentation
---
.../complex-components-docs.factor | 14 ++++++++------
.../complex-components/complex-components.factor | 2 +-
extra/sequences/complex/complex-docs.factor | 10 ++++++----
3 files changed, 15 insertions(+), 11 deletions(-)
diff --git a/extra/sequences/complex-components/complex-components-docs.factor b/extra/sequences/complex-components/complex-components-docs.factor
index de1bed38a7..386735aa7d 100644
--- a/extra/sequences/complex-components/complex-components-docs.factor
+++ b/extra/sequences/complex-components/complex-components-docs.factor
@@ -12,8 +12,8 @@ ABOUT: "sequences.complex-components"
HELP: complex-components
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link complex } " number values into a sequence of " { $link real } " values, interleaving the real and imaginary parts of the complex values in the original sequence." }
{ $examples { $example <"
-USING: sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array
+USING: prettyprint sequences arrays sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> >array .
"> "{ 1.0 -1.0 -2.0 0 3.0 1.0 }" } } ;
HELP: <complex-components>
@@ -21,12 +21,14 @@ HELP: <complex-components>
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-components } " wrapper." }
{ $examples
{ $example <"
-USING: sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third
+USING: prettyprint sequences arrays
+sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> third .
"> "-2.0" }
{ $example <"
-USING: sequences arrays sequences.complex-components ;
-{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth
+USING: prettyprint sequences arrays
+sequences.complex-components ;
+{ C{ 1.0 -1.0 } -2.0 C{ 3.0 1.0 } } <complex-components> fourth .
"> "0" }
} ;
diff --git a/extra/sequences/complex-components/complex-components.factor b/extra/sequences/complex-components/complex-components.factor
index bca7e2c0a2..ae808971b6 100644
--- a/extra/sequences/complex-components/complex-components.factor
+++ b/extra/sequences/complex-components/complex-components.factor
@@ -5,7 +5,7 @@ IN: sequences.complex-components
TUPLE: complex-components seq ;
INSTANCE: complex-components sequence
-: <complex-components> ( sequence -- complex-sequence )
+: <complex-components> ( sequence -- complex-components )
complex-components boa ; inline
<PRIVATE
diff --git a/extra/sequences/complex/complex-docs.factor b/extra/sequences/complex/complex-docs.factor
index d4d8dfc7a2..65dd520fd8 100644
--- a/extra/sequences/complex/complex-docs.factor
+++ b/extra/sequences/complex/complex-docs.factor
@@ -12,18 +12,20 @@ ABOUT: "sequences.complex"
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
{ $examples { $example <"
-USING: specialized-arrays.double sequences.complex
+USING: prettyprint
+specialized-arrays.double sequences.complex
sequences arrays ;
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
HELP: <complex-sequence>
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
{ $examples { $example <"
-USING: specialized-arrays.double sequences.complex
+USING: prettyprint
+specialized-arrays.double sequences.complex
sequences arrays ;
-double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second
+double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
"> "C{ -2.0 2.0 }" } } ;
{ complex-sequence <complex-sequence> } related-words
From 12c8ffc19494b866bc1be006cf27b6ac7fe21037 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 21:22:48 -0600
Subject: [PATCH 20/35] Fix adding methods to existing classes
---
basis/cocoa/cocoa-tests.factor | 26 ++++++++-
basis/cocoa/subclassing/subclassing.factor | 67 ++++++++++------------
2 files changed, 55 insertions(+), 38 deletions(-)
diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor
index e1d6672872..59ea91c3cf 100644
--- a/basis/cocoa/cocoa-tests.factor
+++ b/basis/cocoa/cocoa-tests.factor
@@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units ;
+compiler.units math ;
CLASS: {
{ +superclass+ "NSObject" }
@@ -45,3 +45,27 @@ Bar [
[ 2.0 ] [ "x" get NSRect-y ] unit-test
[ 101.0 ] [ "x" get NSRect-w ] unit-test
[ 102.0 ] [ "x" get NSRect-h ] unit-test
+
+! Make sure that we can add methods
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "Bar" }
+} {
+ "bar"
+ "NSRect"
+ { "id" "SEL" }
+ [ 2drop test-foo "x" get ]
+} {
+ "babb"
+ "int"
+ { "id" "SEL" "int" }
+ [ 2nip sq ]
+} ;
+
+[ 144 ] [
+ Bar [
+ -> alloc -> init
+ dup 12 -> babb
+ swap -> release
+ ] compile-call
+] unit-test
diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 40f21d25b8..b49d55a30b 100644
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime
-compiler.units io.encodings.ascii generalizations
-continuations make ;
+parser sequences words cocoa.messages cocoa.runtime locals
+compiler.units io.encodings.ascii continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
@@ -12,22 +11,25 @@ IN: cocoa.subclassing
[ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ;
-: throw-if-false ( YES/NO -- )
- zero? [ "Failed to add method or protocol to class" throw ]
- when ;
+: throw-if-false ( obj what -- )
+ swap { f 0 } member?
+ [ "Failed to " prepend throw ] [ drop ] if ;
+
+: add-method ( class sel imp types -- )
+ class_addMethod "add method to class" throw-if-false ;
: add-methods ( methods class -- )
- swap
- [ init-method class_addMethod throw-if-false ] with each ;
+ '[ [ _ ] dip init-method add-method ] each ;
+
+: add-protocol ( class protocol -- )
+ class_addProtocol "add protocol to class" throw-if-false ;
: add-protocols ( protocols class -- )
- swap [ objc-protocol class_addProtocol throw-if-false ]
- with each ;
+ '[ [ _ ] dip objc-protocol add-protocol ] each ;
-: (define-objc-class) ( protocols superclass name imeth -- )
- -rot
+: (define-objc-class) ( imeth protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
- [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+ [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
: encode-types ( return types -- encoding )
@@ -45,28 +47,19 @@ IN: cocoa.subclassing
[ first4 prepare-method 3array ] map
] with-compilation-unit ;
-: types= ( a b -- ? )
- [ ascii alien>string ] bi@ = ;
-
-: (verify-method-type) ( class sel types -- )
- [ class_getInstanceMethod method_getTypeEncoding ]
- dip types=
- [ "Objective-C method types cannot be changed once defined" throw ]
- unless ;
-: verify-method-type ( class sel imp types -- class sel imp types )
- 4 ndup nip (verify-method-type) ;
-
-: (redefine-objc-method) ( class method -- )
- init-method ! verify-method-type
- drop
- [ class_getInstanceMethod ] dip method_setImplementation drop ;
+:: (redefine-objc-method) ( class method -- )
+ method init-method [| sel imp types |
+ class sel class_getInstanceMethod [
+ imp method_setImplementation drop
+ ] [
+ class sel imp types add-method
+ ] if*
+ ] call ;
: redefine-objc-methods ( imeth name -- )
dup class-exists? [
- objc_getClass swap [ (redefine-objc-method) ] with each
- ] [
- 2drop
- ] if ;
+ objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
+ ] [ 2drop ] if ;
SYMBOL: +name+
SYMBOL: +protocols+
@@ -76,10 +69,10 @@ SYMBOL: +superclass+
clone [
prepare-methods
+name+ get "cocoa.classes" create drop
- +name+ get 2dup redefine-objc-methods swap [
- +protocols+ get , +superclass+ get , +name+ get , ,
- \ (define-objc-class) ,
- ] [ ] make import-objc-class
+ +name+ get 2dup redefine-objc-methods swap
+ +protocols+ get +superclass+ get +name+ get
+ '[ _ _ _ _ (define-objc-class) ]
+ import-objc-class
] bind ;
: CLASS:
From 0e0e79eb7ec5c6627c2bd979040d80f2c31deaf5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:49:46 -0600
Subject: [PATCH 21/35] Redo how Cocoa event loop is done; fixes problem with
expose, focus issue when closing windows
---
basis/cocoa/application/application.factor | 19 +++++-------
basis/cocoa/messages/messages.factor | 34 ++++++++++++----------
basis/ui/cocoa/cocoa.factor | 21 ++++++++++---
basis/ui/cocoa/tools/tools.factor | 6 ++--
4 files changed, 46 insertions(+), 34 deletions(-)
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index c62fab0f15..ab12a93a31 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -27,17 +27,19 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ;
+: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
+
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
- 0 f CFRunLoopDefaultMode 1
+ NSAnyEventMask f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
: do-event ( app -- ? )
- dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
+ dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
: add-observer ( observer selector name object -- )
[
@@ -49,14 +51,7 @@ FUNCTION: void NSBeep ( ) ;
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
-: finish-launching ( -- ) NSApp -> finishLaunching ;
-
-: cocoa-app ( quot -- )
- [
- call
- finish-launching
- NSApp -> run
- ] with-cocoa ; inline
+: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
@@ -81,6 +76,6 @@ M: objc-error summary ( error -- )
running.app? [
drop
] [
- "The " swap " requires you to run Factor from an application bundle."
- 3append throw
+ "The " " requires you to run Factor from an application bundle."
+ surround throw
] if ;
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 791674428b..4be90a5a95 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -85,9 +85,17 @@ MACRO: (send) ( selector super? -- quot )
\ super-send soft "break-after" set-word-prop
! Runtime introspection
-: (objc-class) ( string word -- class )
- dupd execute
- [ ] [ "No such class: " prepend throw ] ?if ; inline
+SYMBOL: class-init-hooks
+
+class-init-hooks global [ H{ } clone or ] change-at
+
+: (objc-class) ( name word -- class )
+ 2dup execute dup [ 2nip ] [
+ drop over class-init-hooks get at [ call ] when*
+ 2dup execute dup [ 2nip ] [
+ 2drop "No such class: " prepend throw
+ ] if
+ ] if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
@@ -221,23 +229,19 @@ assoc-union alien>objc-types set-global
: class-exists? ( string -- class ) objc_getClass >boolean ;
-: unless-defined ( class quot -- )
- [ class-exists? ] dip unless ; inline
-
-: define-objc-class-word ( name quot -- )
+: define-objc-class-word ( quot name -- )
+ [ class-init-hooks get set-at ]
[
- over , , \ unless-defined , dup , \ objc-class ,
- ] [ ] make [ "cocoa.classes" create ] dip
- (( -- class )) define-declared ;
+ [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
+ (( -- class )) define-declared
+ ] bi ;
: import-objc-class ( name quot -- )
- 2dup unless-defined
- dupd define-objc-class-word
+ over define-objc-class-word
'[
_
- dup
- objc-class register-objc-methods
- objc-meta-class register-objc-methods
+ [ objc-class register-objc-methods ]
+ [ objc-meta-class register-objc-methods ] bi
] try ;
: root-class ( class -- root )
diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor
index a9b3b03b75..42063fbf73 100644
--- a/basis/ui/cocoa/cocoa.factor
+++ b/basis/ui/cocoa/cocoa.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays cocoa cocoa.application
+USING: accessors math arrays assocs cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
@@ -96,16 +96,29 @@ M: cocoa-ui-backend flush-gl-context ( handle -- )
M: cocoa-ui-backend beep ( -- )
NSBeep ;
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "applicationDidFinishLaunching:" "void" { "id" "SEL" "id" }
+ [ 3drop event-loop ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
SYMBOL: cocoa-init-hook
+cocoa-init-hook global [ [ install-app-delegate ] or ] change-at
+
M: cocoa-ui-backend ui
"UI" assert.app [
[
init-clipboard
- cocoa-init-hook get [ call ] when*
+ cocoa-init-hook get call
start-ui
- finish-launching
- event-loop
+ NSApp -> run
] ui-running
] with-cocoa ;
diff --git a/basis/ui/cocoa/tools/tools.factor b/basis/ui/cocoa/tools/tools.factor
index a8ade05a86..ccaae0c1ab 100644
--- a/basis/ui/cocoa/tools/tools.factor
+++ b/basis/ui/cocoa/tools/tools.factor
@@ -20,8 +20,8 @@ IN: ui.cocoa.tools
! Handle Open events from the Finder
CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
+ { +superclass+ "FactorApplicationDelegate" }
+ { +name+ "FactorWorkspaceApplicationDelegate" }
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
@@ -49,7 +49,7 @@ CLASS: {
} ;
: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
+ NSApp FactorWorkspaceApplicationDelegate install-delegate ;
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )
From 6c7005d588b56ea9e3471b3e1bdc952fd5283d87 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:50:14 -0600
Subject: [PATCH 22/35] Tweak inlining heuristic
---
basis/compiler/tree/propagation/inlining/inlining.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 3a94029756..87a908041e 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -128,8 +128,8 @@ DEFER: (flat-length)
45 node-count get [-] 8 /i ;
: body-length-bias ( word -- n )
- [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
- 24 swap [-] 4 /i ;
+ [ flat-length ] [ inlining-count get at 0 or ] bi
+ over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
From 25bf16f6d46f33b6576a23cf4ff407eac2442eba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 01:50:30 -0600
Subject: [PATCH 23/35] Optimize mersenne-twister: eliminate conditional
branches from inner loop, 30% speedup
---
.../mersenne-twister/mersenne-twister.factor | 51 ++++++++-----------
1 file changed, 21 insertions(+), 30 deletions(-)
diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
index 357ab87966..67b0fa23e7 100644
--- a/basis/random/mersenne-twister/mersenne-twister.factor
+++ b/basis/random/mersenne-twister/mersenne-twister.factor
@@ -11,48 +11,39 @@ IN: random.mersenne-twister
TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
-: mt-n 624 ; inline
-: mt-m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
+: n 624 ; inline
+: m 397 ; inline
+: a uint-array{ 0 HEX: 9908b0df } ; inline
-: mersenne-wrap ( n -- n' )
- dup mt-n > [ mt-n - ] when ; inline
+: y ( n seq -- y )
+ [ nth-unsafe 31 mask-bit ]
+ [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
-: wrap-nth ( n seq -- obj )
- [ mersenne-wrap ] dip nth-unsafe ; inline
-
-: set-wrap-nth ( obj n seq -- )
- [ mersenne-wrap ] dip set-nth-unsafe ; inline
-
-: calculate-y ( n seq -- y )
- [ wrap-nth 31 mask-bit ]
- [ [ 1+ ] [ wrap-nth ] bi* 31 bits ] 2bi bitor ; inline
-
-: (mt-generate) ( n seq -- next-mt )
+: mt[k] ( offset n seq -- )
[
- calculate-y
- [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
- ] [
- [ mt-m + ] [ wrap-nth ] bi*
- ] 2bi bitxor ; inline
+ [ [ + ] dip nth-unsafe ]
+ [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi
+ bitxor
+ ] 2keep set-nth-unsafe ; inline
: mt-generate ( mt -- )
[
- mt-n swap seq>> '[
- _ [ (mt-generate) ] [ set-wrap-nth ] 2bi
- ] each
+ seq>>
+ [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
+ [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
- dupd wrap-nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+ dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
: init-mt-rest ( seq -- )
- mt-n 1- swap '[
- _ [ init-mt-formula ] [ [ 1+ ] dip set-wrap-nth ] 2bi
+ n 1- swap '[
+ _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
- 32 bits mt-n <uint-array>
+ 32 bits n <uint-array>
[ set-first ] [ init-mt-rest ] [ ] tri ; inline
: mt-temper ( y -- yt )
@@ -62,7 +53,7 @@ TUPLE: mersenne-twister { seq uint-array } { i fixnum } ;
dup -18 shift bitxor ; inline
: next-index ( mt -- i )
- dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ; inline
+ dup i>> dup n < [ nip ] [ drop mt-generate 0 ] if ; inline
PRIVATE>
@@ -75,7 +66,7 @@ M: mersenne-twister seed-random ( mt seed -- )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
- [ seq>> wrap-nth mt-temper ]
+ [ seq>> nth-unsafe mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
USE: init
From fa146b248a01f33d0d1191d4e872cdae3feff13f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 02:11:50 -0600
Subject: [PATCH 24/35] Remove obsolete info; 1+ and 1- are identical to 1 +
and 1 - in reality
---
core/math/math-docs.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index aca43add5c..3c2b7f67e2 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -166,15 +166,17 @@ HELP: log2
HELP: 1+
{ $values { "x" number } { "y" number } }
{ $description
- "Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
+ "Increments a number by 1. The following two lines are equivalent:"
{ $code "1+" "1 +" }
+ "There is no difference in behavior or efficiency."
} ;
HELP: 1-
{ $values { "x" number } { "y" number } }
{ $description
- "Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
+ "Decrements a number by 1. The following two lines are equivalent:"
{ $code "1-" "1 -" }
+ "There is no difference in behavior or efficiency."
} ;
HELP: ?1+
From 252b1eb5134937a87ecbf4c8e4e6e9dff326d621 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 06:37:19 -0600
Subject: [PATCH 25/35] Faster conversion of sbufs, vectors and byte-vectors to
their corresponding fixed-size type respectively; we call the resize-T
primitive on the underlying sequence instead of >T
---
core/arrays/arrays.factor | 2 --
core/byte-arrays/byte-arrays.factor | 1 -
core/byte-vectors/byte-vectors.factor | 15 ++++++++++++++-
core/sbufs/sbufs.factor | 16 ++++++++--------
core/vectors/vectors.factor | 16 +++++++++++++++-
5 files changed, 37 insertions(+), 13 deletions(-)
diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor
index 74bc57e9db..157ac013e3 100644
--- a/core/arrays/arrays.factor
+++ b/core/arrays/arrays.factor
@@ -16,8 +16,6 @@ M: object new-sequence drop f <array> ;
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
-M: array like drop dup array? [ >array ] unless ;
-
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 50ea4b32ba..f981e758d7 100644
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -9,7 +9,6 @@ M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
index 5d337cb028..6938d02b2f 100644
--- a/core/byte-vectors/byte-vectors.factor
+++ b/core/byte-vectors/byte-vectors.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays ;
+sequences.private growable byte-arrays accessors ;
IN: byte-vectors
TUPLE: byte-vector
@@ -26,6 +26,19 @@ M: byte-vector new-sequence
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;
+M: byte-array like
+ #! If we have an byte-array, we're done.
+ #! If we have a byte-vector, and it's at full capacity,
+ #! we're done. Otherwise, call resize-byte-array, which is a
+ #! relatively fast primitive.
+ drop dup byte-array? [
+ dup byte-vector? [
+ [ length ] [ underlying>> ] bi
+ 2dup length eq?
+ [ nip ] [ resize-byte-array ] if
+ ] [ >byte-array ] if
+ ] unless ;
+
M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable
diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor
index 5a30654f03..5590432ef4 100644
--- a/core/sbufs/sbufs.factor
+++ b/core/sbufs/sbufs.factor
@@ -31,16 +31,16 @@ M: sbuf equal?
M: string new-resizable drop <sbuf> ;
M: string like
+ #! If we have a string, we're done.
+ #! If we have an sbuf, and it's at full capacity, we're done.
+ #! Otherwise, call resize-string, which is a relatively
+ #! fast primitive.
drop dup string? [
dup sbuf? [
- dup length over underlying>> length eq? [
- underlying>> dup reset-string-hashcode
- ] [
- >string
- ] if
- ] [
- >string
- ] if
+ [ length ] [ underlying>> ] bi
+ 2dup length eq?
+ [ nip dup reset-string-hashcode ] [ resize-string ] if
+ ] [ >string ] if
] unless ;
INSTANCE: sbuf growable
diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor
index dab30f306f..b4cade44db 100644
--- a/core/vectors/vectors.factor
+++ b/core/vectors/vectors.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math sequences sequences.private growable ;
+USING: arrays kernel math sequences sequences.private growable
+accessors ;
IN: vectors
TUPLE: vector
@@ -22,6 +23,19 @@ M: vector new-sequence
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
+M: array like
+ #! If we have an array, we're done.
+ #! If we have a vector, and it's at full capacity, we're done.
+ #! Otherwise, call resize-array, which is a relatively
+ #! fast primitive.
+ drop dup array? [
+ dup vector? [
+ [ length ] [ underlying>> ] bi
+ 2dup length eq?
+ [ nip ] [ resize-array ] if
+ ] [ >array ] if
+ ] unless ;
+
M: sequence new-resizable drop <vector> ;
INSTANCE: vector growable
From e256846acd7608532c0ca686b92e2842b18a0401 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 06:38:51 -0600
Subject: [PATCH 26/35] Tweak string representation; high bit indicates if
character has high bits in aux vector. Avoids memory access in common case.
Split set-string-nth into two primitives; set-string-nth-fast is open-coded
by optimizing compiler. 13% improvement on reverse-complement
---
basis/bootstrap/image/image.factor | 5 ++
basis/compiler/cfg/def-use/def-use.factor | 2 +
.../cfg/instructions/instructions.factor | 1 +
.../compiler/cfg/intrinsics/intrinsics.factor | 2 +
.../cfg/intrinsics/slots/slots.factor | 4 +
basis/compiler/codegen/codegen.factor | 8 ++
basis/cpu/architecture/architecture.factor | 1 +
basis/cpu/x86/x86.factor | 23 ++++-
.../known-words/known-words.factor | 3 +-
core/bootstrap/primitives.factor | 3 +-
core/strings/strings.factor | 11 ++-
vm/primitives.c | 3 +-
vm/types.c | 84 ++++++++++++-------
vm/types.h | 3 +-
14 files changed, 113 insertions(+), 40 deletions(-)
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index f352a4a254..380c9b2348 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -351,7 +351,12 @@ M: wrapper '
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
+: check-string ( string -- )
+ [ 127 > ] contains?
+ [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+
: emit-string ( string -- ptr )
+ dup check-string
string type-number object tag-number [
dup length emit-fixnum
f ' emit
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 3825ae480e..068a6a6377 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -15,6 +15,7 @@ M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##set-string-nth-fast defs-vregs temp>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
@@ -31,6 +32,7 @@ M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
+M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 62d4990c92..2e7e044739 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index aaa45c3937..cfc04fa036 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -45,6 +45,7 @@ IN: compiler.cfg.intrinsics
slots.private:slot
slots.private:set-slot
strings.private:string-nth
+ strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
@@ -126,6 +127,7 @@ IN: compiler.cfg.intrinsics
{ \ slots.private:slot [ emit-slot iterate-next ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
+ { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index fec234a576..60ae1d2d0a 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -54,3 +54,7 @@ IN: compiler.cfg.intrinsics.slots
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+ 3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
+ swap i ##set-string-nth-fast ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 2161c8b091..96db72c6ea 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -131,6 +131,14 @@ M: ##string-nth generate-insn
[ temp>> register ]
} cleave %string-nth ;
+M: ##set-string-nth-fast generate-insn
+ {
+ [ src>> register ]
+ [ obj>> register ]
+ [ index>> register ]
+ [ temp>> register ]
+ } cleave %set-string-nth-fast ;
+
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 12b6809df9..eb93a8dbb5 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -59,6 +59,7 @@ HOOK: %set-slot cpu ( src obj slot tag temp -- )
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
HOOK: %string-nth cpu ( dst obj index temp -- )
+HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
HOOK: %add cpu ( dst src1 src2 -- )
HOOK: %add-imm cpu ( dst src1 src2 -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 3dbcd2eabf..d7234eb389 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -365,23 +365,38 @@ M:: x86 %box-alien ( dst src temp -- )
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
+ ! Load the least significant 7 bits into new-dst.
+ ! 8th bit indicates whether we have to load from
+ ! the aux vector or not.
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
+ ! Do we have to look at the aux vector?
+ new-dst HEX: 80 CMP
+ "end" get JL
+ ! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
- temp \ f tag-number CMP
- "end" get JE
new-dst temp XCHG
+ ! Compute index
new-dst index ADD
new-dst index ADD
+ ! Load high 16 bits
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
- new-dst 8 SHL
- new-dst temp OR
+ new-dst 7 SHL
+ ! Compute code point
+ new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
+M:: x86 %set-string-nth-fast ( ch str index temp -- )
+ ch { index str } [| new-ch |
+ new-ch ch ?MOV
+ temp str index [+] LEA
+ temp string-offset [+] new-ch 1 small-reg MOV
+ ] with-small-register ;
+
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 26e1b81c93..2cb3d1f006 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -562,7 +562,8 @@ M: object infer-call*
\ string-nth { fixnum string } { fixnum } define-primitive
\ string-nth make-flushable
-\ set-string-nth { fixnum fixnum string } { } define-primitive
+\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
+\ set-string-nth-fast { fixnum fixnum string } { } define-primitive
\ resize-array { integer array } { array } define-primitive
\ resize-array make-flushable
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index a4cee5c7b9..0a7e5fe233 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -499,7 +499,8 @@ tuple
{ "alien-address" "alien" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
- { "set-string-nth" "strings.private" }
+ { "set-string-nth-fast" "strings.private" }
+ { "set-string-nth-slow" "strings.private" }
{ "resize-array" "arrays" }
{ "resize-string" "strings" }
{ "<array>" "arrays" }
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 39628ede98..0c3f918fdc 100644
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -16,6 +16,10 @@ IN: strings
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
+: set-string-nth ( ch n str -- )
+ pick HEX: 7f fixnum<=
+ [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
+
PRIVATE>
M: string equal?
@@ -27,8 +31,9 @@ M: string equal?
] if ;
M: string hashcode*
- nip dup string-hashcode [ ]
- [ dup rehash-string string-hashcode ] ?if ;
+ nip
+ dup string-hashcode
+ [ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length
length>> ;
@@ -38,7 +43,7 @@ M: string nth-unsafe
M: string set-nth-unsafe
dup reset-string-hashcode
- [ [ >fixnum ] dip >fixnum ] dip set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
M: string clone
(clone) [ clone ] change-aux ;
diff --git a/vm/primitives.c b/vm/primitives.c
index 135d5478ea..a01a8653b7 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -105,7 +105,8 @@ void *primitives[] = {
primitive_alien_address,
primitive_set_slot,
primitive_string_nth,
- primitive_set_string_nth,
+ primitive_set_string_nth_fast,
+ primitive_set_string_nth_slow,
primitive_resize_array,
primitive_resize_string,
primitive_array,
diff --git a/vm/types.c b/vm/types.c
index d6e78013cb..a614011e7e 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -328,43 +328,62 @@ void primitive_tuple_boa(void)
/* Strings */
CELL string_nth(F_STRING* string, CELL index)
{
+ /* If high bit is set, the most significant 16 bits of the char
+ come from the aux vector. The least significant bit of the
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
CELL ch = bget(SREF(string,index));
- if(string->aux == F)
+ if((ch & 0x80) == 0)
return ch;
else
{
F_BYTE_ARRAY *aux = untag_object(string->aux);
- return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch;
+ return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
}
}
-/* allocates memory */
-void set_string_nth(F_STRING* string, CELL index, CELL value)
+void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
{
- bput(SREF(string,index),value & 0xff);
+ bput(SREF(string,index),ch);
+}
+void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
+{
F_BYTE_ARRAY *aux;
+ bput(SREF(string,index),(ch & 0x7f) | 0x80);
+
if(string->aux == F)
{
- if(value <= 0xff)
- return;
- else
- {
- REGISTER_UNTAGGED(string);
- aux = allot_byte_array(
- untag_fixnum_fast(string->length)
- * sizeof(u16));
- UNREGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(string);
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_byte_array_internal(
+ untag_fixnum_fast(string->length)
+ * sizeof(u16));
+ UNREGISTER_UNTAGGED(string);
- write_barrier((CELL)string);
- string->aux = tag_object(aux);
- }
+ write_barrier((CELL)string);
+ string->aux = tag_object(aux);
}
else
aux = untag_object(string->aux);
- cput(BREF(aux,index * sizeof(u16)),value >> 8);
+ cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(F_STRING* string, CELL index, CELL ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(string,index,ch);
+ else
+ set_string_nth_slow(string,index,ch);
}
/* untagged */
@@ -382,17 +401,8 @@ F_STRING* allot_string_internal(CELL capacity)
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
- if(fill == 0)
- {
- memset((void *)SREF(string,start),'\0',capacity - start);
-
- if(string->aux != F)
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- memset((void *)BREF(aux,start * sizeof(u16)),'\0',
- (capacity - start) * sizeof(u16));
- }
- }
+ if(fill <= 0x7f)
+ memset((void *)SREF(string,start),fill,capacity - start);
else
{
CELL i;
@@ -572,3 +582,19 @@ void primitive_set_string_nth(void)
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
+
+void primitive_set_string_nth_fast(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_fast(string,index,value);
+}
+
+void primitive_set_string_nth_slow(void)
+{
+ F_STRING *string = untag_object(dpop());
+ CELL index = untag_fixnum_fast(dpop());
+ CELL value = untag_fixnum_fast(dpop());
+ set_string_nth_slow(string,index,value);
+}
diff --git a/vm/types.h b/vm/types.h
index 47747547db..242939c502 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -152,7 +152,8 @@ CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
void primitive_string_nth(void);
-void primitive_set_string_nth(void);
+void primitive_set_string_nth_slow(void);
+void primitive_set_string_nth_fast(void);
F_WORD *allot_word(CELL vocab, CELL name);
void primitive_word(void);
From 8db24bdd34b6de9c5b20389e50f7a4491e565991 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 08:25:26 -0600
Subject: [PATCH 27/35] assert-depth now has a static stack effect. This fixes
a UI unit test failure
---
basis/cocoa/messages/messages.factor | 2 +-
basis/help/lint/lint.factor | 23 ++++++++++----------
basis/tools/test/test-docs.factor | 2 +-
basis/tools/test/test-tests.factor | 4 ++++
basis/tools/test/test.factor | 2 +-
core/combinators/combinators-docs.factor | 12 ----------
core/combinators/combinators.factor | 16 --------------
core/continuations/continuations-docs.factor | 5 +++++
core/continuations/continuations.factor | 3 +++
core/kernel/kernel-docs.factor | 6 +++++
core/parser/parser-tests.factor | 4 +++-
core/parser/parser.factor | 2 +-
12 files changed, 37 insertions(+), 44 deletions(-)
create mode 100644 basis/tools/test/test-tests.factor
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 4be90a5a95..1c5342b389 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -91,7 +91,7 @@ class-init-hooks global [ H{ } clone or ] change-at
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-init-hooks get at [ call ] when*
+ drop over class-init-hooks get at [ assert-depth ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index c7d505d86a..0a392733ac 100644
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -67,7 +67,7 @@ IN: help.lint
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
] each ;
-: check-rendering ( word element -- )
+: check-rendering ( element -- )
[ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
@@ -87,13 +87,14 @@ M: help-error error.
: check-word ( word -- )
dup word-help [
[
- dup word-help [
- 2dup check-examples
- 2dup check-values
- 2dup check-see-also
- 2dup nip check-modules
- 2dup drop check-rendering
- ] assert-depth 2drop
+ dup word-help '[
+ _ _ {
+ [ check-examples ]
+ [ check-values ]
+ [ check-see-also ]
+ [ [ check-rendering ] [ check-modules ] bi* ]
+ } 2cleave
+ ] assert-depth
] check-something
] [ drop ] if ;
@@ -101,9 +102,9 @@ M: help-error error.
: check-article ( article -- )
[
- dup article-content [
- 2dup check-modules check-rendering
- ] assert-depth 2drop
+ dup article-content
+ '[ _ check-rendering _ check-modules ]
+ assert-depth
] check-something ;
: files>vocabs ( -- assoc )
diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
index f19ffb83a4..3cabff457f 100644
--- a/basis/tools/test/test-docs.factor
+++ b/basis/tools/test/test-docs.factor
@@ -86,7 +86,7 @@ HELP: test-all
{ $description "Runs unit tests for all loaded vocabularies." } ;
HELP: run-all-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
+{ $values { "failures" "an association list of unit test failures" } }
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
HELP: test-failures.
diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor
new file mode 100644
index 0000000000..473335645f
--- /dev/null
+++ b/basis/tools/test/test-tests.factor
@@ -0,0 +1,4 @@
+IN: tools.test.tests
+USING: tools.test ;
+
+\ test-all must-infer
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index 080db86338..704a7f1bd5 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -88,7 +88,7 @@ SYMBOL: this-test
: test ( prefix -- )
run-tests test-failures. ;
-: run-all-tests ( prefix -- failures )
+: run-all-tests ( -- failures )
"" run-tests ;
: test-all ( -- )
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index 3afc0a3c3d..8d1d9f0d2a 100644
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -29,17 +29,9 @@ $nl
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
-{ $subsection "assertions" }
{ $subsection "combinators-quot" }
{ $see-also "quotations" "dataflow" } ;
-ARTICLE: "assertions" "Assertions"
-"Some words to make assertions easier to enforce:"
-{ $subsection assert }
-{ $subsection assert= }
-"Runtime stack depth checking:"
-{ $subsection assert-depth } ;
-
ABOUT: "combinators"
HELP: cleave
@@ -167,7 +159,3 @@ HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }
{ $description "Calls the " { $snippet "n" } "th quotation in the array." }
{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is an implementation detail used by the generic word system to accelerate method dispatch. It does not perform type or bounds checks, and user code should not need to call it directly." } ;
-
-HELP: assert-depth
-{ $values { "quot" "a quotation" } }
-{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 68eef23691..6edec815da 100644
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -134,22 +134,6 @@ ERROR: no-case ;
[ drop linear-case-quot ]
} cond ;
-! assert-depth
-: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ;
-
-ERROR: relative-underflow stack ;
-
-ERROR: relative-overflow stack ;
-
-: assert-depth ( quot -- )
- [ datastack ] dip dip [ datastack ] dip
- 2dup [ length ] compare {
- { +lt+ [ trim-datastacks nip relative-underflow ] }
- { +eq+ [ 2drop ] }
- { +gt+ [ trim-datastacks drop relative-overflow ] }
- } case ; inline
-
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index f57be71ca8..3632482162 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -83,6 +83,7 @@ $nl
{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
+{ $subsection assert-depth }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
@@ -216,6 +217,10 @@ HELP: with-datastack
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
+HELP: assert-depth
+{ $values { "quot" "a quotation" } }
+{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
+
HELP: <continuation>
{ $description "Constructs a new continuation." }
{ $notes "User code should call " { $link continuation } " instead." } ;
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 0f55009608..c7056856b6 100644
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -114,6 +114,9 @@ SYMBOL: return-continuation
] 3 (throw)
] callcc1 2nip ;
+: assert-depth ( quot -- )
+ { } swap with-datastack { } assert= ; inline
+
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 5ee12ddedc..01ef8d480d 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -887,6 +887,11 @@ $nl
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
+ARTICLE: "assertions" "Assertions"
+"Some words to make assertions easier to enforce:"
+{ $subsection assert }
+{ $subsection assert= } ;
+
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
@@ -902,6 +907,7 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
+{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 1e93a762f2..cc97b78eb6 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -5,6 +5,8 @@ sorting classes.tuple compiler.units debugger vocabs
vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
+\ run-file must-infer
+
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
@@ -400,7 +402,7 @@ IN: parser.tests
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
-[ stack>> { 1 2 3 } sequence= ]
+[ got>> { 1 2 3 } sequence= ]
must-fail-with
2 [
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 49ab0eb7d4..3f3af935b6 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -307,7 +307,7 @@ print-use-hook global [ [ ] or ] change-at
] recover ;
: run-file ( file -- )
- [ dup parse-file call ] assert-depth drop ;
+ [ parse-file call ] curry assert-depth ;
: ?run-file ( path -- )
dup exists? [ run-file ] [ drop ] if ;
From 5e0653ce6b8d9955e50a1a05dc31d0bd2f7fb2ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:03:55 -0600
Subject: [PATCH 28/35] Fix USING:
---
basis/cocoa/messages/messages.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 1c5342b389..e33217a691 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -1,11 +1,11 @@
! 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 compiler.alien kernel math namespaces make
-parser prettyprint prettyprint.sections quotations sequences
-strings words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation fry generalizations
+continuations combinators compiler compiler.alien kernel math
+namespaces make parser prettyprint prettyprint.sections
+quotations sequences strings words cocoa.runtime io macros
+memoize debugger io.encodings.ascii effects libc libc.private
+parser lexer init core-foundation fry generalizations
specialized-arrays.direct.alien ;
IN: cocoa.messages
From 0f8735554b6b7ba906c69c7b56b4cf95fd8e7bf9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:04:02 -0600
Subject: [PATCH 29/35] These errors don't exist anymore
---
basis/debugger/debugger.factor | 6 ------
1 file changed, 6 deletions(-)
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 94ceff8a23..35b09713d3 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -72,12 +72,6 @@ M: string error. print ;
: try ( quot -- )
[ print-error-and-restarts ] recover ;
-M: relative-underflow summary
- drop "Too many items removed from data stack" ;
-
-M: relative-overflow summary
- drop "Superfluous items pushed to data stack" ;
-
: expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ;
From aa838dbc2da589457c3854fd890934d62d788e7f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 5 Dec 2008 09:04:16 -0600
Subject: [PATCH 30/35] Fix compile errors
---
basis/compiler/codegen/fixup/fixup.factor | 2 +-
.../tree/propagation/known-words/known-words.factor | 7 +++----
basis/stack-checker/backend/backend.factor | 2 +-
basis/threads/threads.factor | 6 +++---
core/io/streams/c/c.factor | 6 +++---
5 files changed, 11 insertions(+), 12 deletions(-)
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 0302218652..a56ae04a7b 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -9,7 +9,7 @@ IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
-: code-format 22 getenv ;
+: code-format ( -- n ) 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 163b17094a..59e2c0b9db 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -144,10 +144,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
comparison-ops
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
-generic-comparison-ops [
- dup specific-comparison
- '[ _ _ define-comparison-constraints ] each-derived-op
-] each
+! generic-comparison-ops [
+! dup specific-comparison define-comparison-constraints
+! ] each
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 07030085a6..7f8c920b19 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -148,7 +148,7 @@ M: object apply-object push-literal ;
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
- [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ [ def>> [ word? ] contains? ]
} cond ;
: ?missing-effect ( word -- )
diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 1e04ad88c2..305ef0cca3 100644
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -36,7 +36,7 @@ sleep-entry ;
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads 64 getenv ;
+: threads ( -- assoc ) 64 getenv ;
: thread ( id -- thread ) threads at ;
@@ -73,9 +73,9 @@ PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
-: run-queue 65 getenv ;
+: run-queue ( -- dlist ) 65 getenv ;
-: sleep-queue 66 getenv ;
+: sleep-queue ( -- heap ) 66 getenv ;
: resume ( thread -- )
f >>state
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index 47e19d2c40..71c9ffd7d9 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -56,9 +56,9 @@ M: c-reader dispose*
M: c-io-backend init-io ;
-: stdin-handle 11 getenv ;
-: stdout-handle 12 getenv ;
-: stderr-handle 61 getenv ;
+: stdin-handle ( -- alien ) 11 getenv ;
+: stdout-handle ( -- alien ) 12 getenv ;
+: stderr-handle ( -- alien ) 61 getenv ;
: init-c-stdio ( -- stdin stdout stderr )
stdin-handle <c-reader>
From 29aeb707c1b044bdbf46aeccaa1e6781f59c24a3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:35:10 -0600
Subject: [PATCH 31/35] fix load error
---
basis/html/templates/chloe/compiler/compiler.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor
index ac784f8c2a..d4f34ab8aa 100644
--- a/basis/html/templates/chloe/compiler/compiler.factor
+++ b/basis/html/templates/chloe/compiler/compiler.factor
@@ -3,7 +3,7 @@
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 html.templates.chloe.syntax ;
+html.templates html.templates.chloe.syntax continuations ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
From f126d0c0e6fcf3ef8833a7fd18efb5f531bbad87 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:36:41 -0600
Subject: [PATCH 32/35] fix compile error
---
basis/logging/server/server.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor
index 47656e8655..1872bb0af2 100644
--- a/basis/logging/server/server.factor
+++ b/basis/logging/server/server.factor
@@ -26,7 +26,7 @@ SYMBOL: log-files
: log-stream ( service -- stream )
log-files get [ open-log-stream ] cache ;
-: multiline-header 20 CHAR: - <string> ; foldable
+: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
: (write-message) ( msg name>> level multi? -- )
[
From 320f3555419b5e94a0a4770c3490de468c7e88c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 11:39:24 -0600
Subject: [PATCH 33/35] fix load error
---
basis/html/templates/chloe/chloe.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index da3f80e9a5..73cc239a56 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -4,6 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
namespaces make classes.tuple assocs splitting words arrays io
io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml logging
+continuations
xml.data
html.forms
html.elements
From 3293dde7a2aa19c3498d79ae543dc713f39424d1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 12:53:23 -0600
Subject: [PATCH 34/35] remove unit test
---
core/vocabs/loader/loader-tests.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 7b53e98df1..e5bd74a981 100644
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -154,9 +154,6 @@ forget-junk
[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
-[ "vocabs.loader.test.e" require ]
-[ relative-overflow? ] must-fail-with
-
0 "vocabs.loader.test.g" set-global
[
From 2e31f7d79230f622bed2650e351baab25fbcc50e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 5 Dec 2008 12:57:36 -0600
Subject: [PATCH 35/35] fix help-lint errors
---
basis/threads/threads-docs.factor | 5 +++--
core/io/streams/c/c-docs.factor | 6 +++---
2 files changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index cc2216545d..a1d7e50594 100644
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations init quotations strings
-assocs heaps boxes namespaces deques ;
+assocs heaps boxes namespaces deques dlists ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
@@ -82,7 +82,7 @@ $nl
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
HELP: run-queue
-{ $values { "queue" deque } }
+{ $values { "dlist" dlist } }
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
$nl
"By convention, threads are queued with " { $link push-front }
@@ -97,6 +97,7 @@ HELP: resume-with
{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ;
HELP: sleep-queue
+{ $values { "heap" min-heap } }
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
HELP: sleep-time
diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor
index 6c640bbdeb..a579153353 100644
--- a/core/io/streams/c/c-docs.factor
+++ b/core/io/streams/c/c-docs.factor
@@ -61,13 +61,13 @@ HELP: fread ( n alien -- str/f )
{ $errors "Throws an error if the input operation failed." } ;
HELP: stdin-handle
-{ $values { "in" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard input file handle." } ;
HELP: stdout-handle
-{ $values { "out" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard output file handle." } ;
HELP: stderr-handle
-{ $values { "out" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard error file handle." } ;