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

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

db4
Guillaume Nargeot 2009-09-08 17:22:35 +09:00
parent a0b6d4f381 9f9b6bca01
commit 62c12b2238
15 changed files with 156 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/classes/struct/struct-tests.factor
View File

@ -316,6 +316,11 @@ STRUCT: struct-test-optimization
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
[ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
{ x>> } inlined?
] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
@ -340,3 +345,4 @@ STRUCT: struct-that's-a-word { x int } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test

8
basis/classes/struct/struct.factor
View File

@ -42,11 +42,9 @@ M: struct hashcode*
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
[ 1array ] dip slots>tuple ;
\ memory>struct [
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
! This is sub-optimal if the class is not literal, but gets
! optimized down to efficient code if it is.
'[ _ boa ] call( ptr -- struct ) ; inline
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )

10
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
View File

@ -47,9 +47,15 @@ IN: compiler.tree.propagation.call-effect.tests
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
! This should get inlined, because the parameter to the curry is literal even though
! [ boa ] by itself doesn't infer
TUPLE: a-tuple x ;
[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test

84
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -50,12 +50,12 @@ M: curry cached-effect
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect )
[ infer ] [ 2drop +unknown+ ] recover ;
M: quotation cached-effect
dup cached-effect>>
[ ] [
[ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
(>>cached-effect)
] ?if ;
[ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
@ -116,6 +116,29 @@ M: quotation cached-effect
: execute-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ execute-effect-ic ] ;
! Some bookkeeping to make sure that crap like
! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
! doesn't hang the compiler.
GENERIC: already-inlined-quot? ( quot -- ? )
M: curry already-inlined-quot? quot>> already-inlined-quot? ;
M: compose already-inlined-quot?
[ first>> already-inlined-quot? ]
[ second>> already-inlined-quot? ] bi or ;
M: quotation already-inlined-quot? already-inlined? ;
GENERIC: add-quot-to-history ( quot -- )
M: curry add-quot-to-history quot>> add-quot-to-history ;
M: compose add-quot-to-history
[ first>> add-quot-to-history ]
[ second>> add-quot-to-history ] bi ;
M: quotation add-quot-to-history add-to-history ;
: last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
@ -129,22 +152,18 @@ ERROR: uninferable ;
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
dup class>> {
{ \ quotation [
literal>> [ uninferable ] unless*
dup already-inlined? [ uninferable ] when
cached-effect dup +unknown+ = [ uninferable ] when
] }
{ \ curry [
slots>> third (infer-value)
remove-effect-input
] }
{ \ compose [
slots>> last2 [ (infer-value) ] bi@
compose-effects
] }
[ uninferable ]
} case ;
dup literal?>> [
literal>>
[ callable? [ uninferable ] unless ]
[ already-inlined-quot? [ uninferable ] when ]
[ safe-infer dup +unknown+ = [ uninferable ] when ] tri
] [
dup class>> {
{ \ curry [ slots>> third (infer-value) remove-effect-input ] }
{ \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
[ uninferable ]
} case
] if ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
@ -152,17 +171,20 @@ ERROR: uninferable ;
recover ;
: (value>quot) ( value-info -- quot )
dup class>> {
{ \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
] }
{ \ compose [
slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ]
] }
} case ;
dup literal?>> [
literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
] [
dup class>> {
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
] }
{ \ compose [
slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ]
] }
} case
] if ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;

14
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -97,11 +97,9 @@ SYMBOL: history
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
[
word add-to-history
dup (propagate)
] with-scope
#call (>>body) t
word add-to-history
#call (>>body)
#call propagate-body
] [ f ] if*
] if ;
@ -141,5 +139,7 @@ SYMBOL: history
#! Note the logic here: if there's a custom inlining hook,
#! it is permitted to return f, which means that we try the
#! normal inlining heuristic.
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
[ 2drop t ] [ (do-inlining) ] if ;
[
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
[ 2drop t ] [ (do-inlining) ] if
] with-scope ;

3
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -799,3 +799,6 @@ SYMBOL: not-an-assoc
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
! Don't crash if bad literal inputs are passed to unsafe words
[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test

26
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays alien.c-types
math math.private slots generic definitions
stack-checker.state
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
combinators.short-circuit classes classes.tuple
classes.tuple.private continuations arrays alien.c-types math
math.private slots generic definitions stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -63,9 +63,19 @@ M: #declare propagate-before
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
: literal-inputs? ( #call -- ? )
in-d>> [ value-info literal?>> ] all? ;
: input-classes-match? ( #call word -- ? )
[ in-d>> ] [ "input-classes" word-prop ] bi*
[ [ value-info literal>> ] dip instance? ] 2all? ;
: foldable-call? ( #call word -- ? )
"foldable" word-prop
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
{
[ nip "foldable" word-prop ]
[ drop literal-inputs? ]
[ input-classes-match? ]
} 2&& ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*

11
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -1,6 +1,7 @@
IN: struct-arrays.tests
USING: classes.struct struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors sequences.private ;
alien.syntax alien.c-types destructors libc accessors sequences.private
compiler.tree.debugger ;
STRUCT: test-struct-array
{ x int }
@ -52,4 +53,10 @@ STRUCT: fixed-string { text char[100] } ;
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
] unit-test
[ 10 "int" <struct-array> ] must-fail
[ 10 "int" <struct-array> ] must-fail
STRUCT: wig { x int } ;
: <bacon> ( -- wig ) 0 wig <struct-boa> ; inline
: waterfall ( -- a b ) 1 wig <struct-array> <bacon> swap first x>> ; inline
[ t ] [ [ waterfall ] { x>> } inlined? ] unit-test

4
basis/tools/deploy/deploy-tests.factor
View File

@ -101,4 +101,8 @@ M: quit-responder call-responder*
os windows? os macosx? or [
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
] when
os macosx? [
[ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
] when

26
basis/tools/deploy/test/14/14.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct cocoa cocoa.classes
cocoa.subclassing core-graphics.types kernel math ;
IN: tools.deploy.test.14
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar:"
"float"
{ "id" "SEL" "NSRect" }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]
bi +
]
} ;
: main ( -- )
Bar -> alloc -> init
S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar:
10.0 assert= ;
MAIN: main

1
basis/tools/deploy/test/14/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/tools/deploy/test/14/deploy.factor Normal file
View File

@ -0,0 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-c-types? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-ui? f }
{ deploy-unicode? f }
{ deploy-name "tools.deploy.test.14" }
}

1
basis/tools/deploy/test/14/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
core/make/make-docs.factor
View File

@ -23,7 +23,7 @@ $nl
"and"
{ $code "[ [ reverse % ] each ] \"\" make" }
"is equivalent to"
{ $code "[ [ reverse ] map concat" }
{ $code "[ reverse ] map concat" }
{ $heading "Utilities for simple make patterns" }
"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
@ -70,4 +70,4 @@ HELP: ,
HELP: %
{ $values { "seq" sequence } }
{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;

2
core/sequences/sequences-docs.factor
View File

@ -278,7 +278,7 @@ HELP: reduce-index
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
{ $examples