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

Conflicts:

	basis/compiler/tree/propagation/propagation-tests.factor

diff --combined basis/compiler/tree/propagation/inlining/inlining.factor
index 016440c799ad55d8abce75b1195d83b2c3f04a3c,5375ff68819b246ebc1ec373aaee31cfd019f940..e6c63f149ad827bef29e21ac0f112097e56c8d67
--- 1/basis/compiler/tree/propagation/inlining/inlining.factor
--- 2/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@@ -5,7 -5,6 +5,7 @@@ math.partial-dispatch generic generic.s
  classes.algebra classes.union sets quotations assocs combinators
  combinators.short-circuit words namespaces continuations classes
  fry hints locals
 +stack-checker.dependencies
  compiler.tree
  compiler.tree.builder
  compiler.tree.recursive
@@@ -48,31 -47,12 +48,31 @@@ M: callable splicing-nodes splicing-bod
          ] if
      ] [ 2drop undo-inlining ] if ;
  
 +ERROR: bad-splitting class generic ;
 +
 +:: split-code ( class generic -- quot/f )
 +    class generic method :> my-method
 +    my-method [ class generic bad-splitting ] unless
 +    class generic my-method depends-on-method-is
 +    generic dispatch# (picker) :> picker
 +    [
 +        picker call class instance?
 +        [ my-method execute ]
 +        [ generic no-method ] if
 +    ] ;
 +
 +:: split-method-call ( class generic -- quot/f )
 +    class generic subclass-with-only-method [
 +        [ class generic depends-on-single-method ]
 +        [ generic split-code ] bi
 +    ] [ f ] if* ;
 +
  : inlining-standard-method ( #call word -- class/f method/f )
      dup "methods" word-prop assoc-empty? [ 2drop f f ] [
          2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
              [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
              [ swap nth value-info class>> dup ] dip
 -            method-for-class
 +            { [ method-for-class ] [ split-method-call ] } 2||
          ] if
      ] if ;
  
@@@ -110,7 -90,7 +110,7 @@@ SYMBOL: histor
      word already-inlined? [ f ] [
          #call word splicing-body [
              word add-to-history
-             #call (>>body)
+             #call body<<
              #call propagate-body
          ] [ f ] if*
      ] if ;

diff --combined basis/compiler/tree/propagation/propagation-tests.factor
index 07024f7e0d04b2eb6e785b534d93d4df2f6a5d12,e738a70fc3377f604aed521ca1ac6486cf542270..d083b39b5bc98d14c4224d60fdabc0b7cb9ecada
--- 1/basis/compiler/tree/propagation/propagation-tests.factor
--- 2/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@@ -9,7 -9,7 +9,7 @@@ compiler.tree.debugger compiler.tree.ch
  hashtables classes assocs locals specialized-arrays system
  sorting math.libm math.floats.private math.integers.private
  math.intervals quotations effects alien alien.data sets
 -strings.private ;
 +strings.private classes.tuple eval ;
  FROM: math => float ;
  SPECIALIZED-ARRAY: double
  SPECIALIZED-ARRAY: void*
@@@ -693,7 -693,7 +693,7 @@@ M: fixnum bad-generic 1 fixnum+fast ; i
  
  [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
  
 -[ V{ number } ] [
 +[ V{ integer } ] [
      [
          0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
      ] final-classes
@@@ -863,11 -863,11 +863,11 @@@ TUPLE: foo bar 
  GENERIC: whatever ( x -- y )
  M: number whatever drop foo ; inline
  
 -[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
 +[ t ] [ [ 1 whatever new ] { new } M\ tuple-class new suffix inlined? ] unit-test
  
  : that-thing ( -- class ) foo ;
  
 -[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
 +[ f ] [ [ that-thing new ] { new } M\ tuple-class new suffix inlined? ] unit-test
  
  GENERIC: whatever2 ( x -- y )
  M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
@@@ -977,41 -977,21 +977,60 @@@ M: tuple-with-read-only-slot clon
      [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
  ] unit-test
  
 +! Optimization on instance?
 +[ f ] [ [ { number } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +
 +UNION: ?fixnum fixnum POSTPONE: f ;
 +[ t ] [ [ { ?fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +[ t ] [ [ { fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
 +
 +! Actually check to make sure that the generated code works properly
 +: instance-test-1 ( x -- ? ) { ?fixnum } declare fixnum instance? ;
 +: instance-test-2 ( x -- ? ) { number } declare fixnum instance? ;
 +: instance-test-3 ( x -- ? ) { POSTPONE: f } declare \ f instance? ;
 +
 +[ t ] [ 1 instance-test-1 ] unit-test
 +[ f ] [ f instance-test-1 ] unit-test
 +[ t ] [ 1 instance-test-2 ] unit-test
 +[ f ] [ 1.1 instance-test-2 ] unit-test
 +[ t ] [ f instance-test-3 ] unit-test
 +
 +[ t ] [ [ { ?fixnum } declare >fixnum ] { >fixnum } inlined? ] unit-test
 +[ f ] [ [ { integer } declare >fixnum ] { >fixnum } inlined? ] unit-test
 +
 +[ f ] [ [ { word } declare parent-word ] { parent-word } inlined? ] unit-test
 +
 +! Make sure guarded method inlining installs the right dependencies
 +
 +[ ] [
 +    "IN: compiler.tree.propagation.tests
 +    USING: kernel.private accessors ;
 +    TUPLE: foo bar ;
 +    UNION: ?foo foo POSTPONE: f ;
 +    : baz ( ?foo -- bar ) { ?foo } declare bar>> ;" eval( -- )
 +] unit-test
 +
 +[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 3 foo boa baz" eval( -- x ) ] unit-test
 +
 +[ ] [ "IN: compiler.tree.propagation.tests TUPLE: foo baz bar ;" eval( -- ) ] unit-test
 +
 +[ 3 ] [ "USE: kernel IN: compiler.tree.propagation.tests 2 3 foo boa baz" eval( -- x ) ] unit-test
++
+ ! Non-zero displacement for <displaced-alien> restricts the output type
+ [ t ] [
+     [ { byte-array } declare <displaced-alien> ] final-classes
+     first byte-array alien class-or class=
+ ] unit-test
+ 
+ [ V{ alien } ] [
+     [ { alien } declare <displaced-alien> ] final-classes
+ ] unit-test
+ 
+ [ t ] [
+     [ { POSTPONE: f } declare <displaced-alien> ] final-classes
+     first \ f alien class-or class=
+ ] unit-test
+ 
+ [ V{ alien } ] [
+     [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
+ ] unit-test