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

basis/colors/constants/factor-colors.txt

@@ -4,3 +4,4 @@
 172 167 147		FactorDarkTan
  81  91 105		FactorLightSlateBlue
  55  62  72		FactorDarkSlateBlue
+  0  51   0     FactorDarkGreen

basis/compiler/cfg/hats/hats.factor

@@ -45,6 +45,7 @@ insn-classes get [
     [ next-vreg dup ] dip {
         { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
         { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+        { [ dup float? ] [ ##load-constant ] }
         [ ##load-reference ]
     } cond ;
 

basis/compiler/cfg/instructions/instructions.factor

@@ -29,6 +29,10 @@ INSN: ##load-reference
 def: dst/int-rep
 constant: obj ;
 
+INSN: ##load-constant
+def: dst/int-rep
+constant: obj ;
+
 INSN: ##peek
 def: dst/int-rep
 literal: loc ;
@@ -464,65 +468,88 @@ use: src/int-rep ;
 ! Alien accessors
 INSN: ##alien-unsigned-1
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-unsigned-2
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-unsigned-4
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-signed-1
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-signed-2
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-signed-4
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-cell
 def: dst/int-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-float
 def: dst/float-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-double
 def: dst/double-rep
-use: src/int-rep ;
+use: src/int-rep
+literal: offset ;
 
 INSN: ##alien-vector
 def: dst
 use: src/int-rep
-literal: rep ;
+literal: offset rep ;
 
 INSN: ##set-alien-integer-1
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
 
 INSN: ##set-alien-integer-2
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
 
 INSN: ##set-alien-integer-4
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
 
 INSN: ##set-alien-cell
-use: src/int-rep value/int-rep ;
+use: src/int-rep
+literal: offset
+use: value/int-rep ;
 
 INSN: ##set-alien-float
-use: src/int-rep value/float-rep ;
+use: src/int-rep
+literal: offset
+use: value/float-rep ;
 
 INSN: ##set-alien-double
-use: src/int-rep value/double-rep ;
+use: src/int-rep
+literal: offset
+use: value/double-rep ;
 
 INSN: ##set-alien-vector
-use: src/int-rep value
+use: src/int-rep
+literal: offset
+use: value
 literal: rep ;
 
 ! Memory allocation

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -33,10 +33,10 @@ IN: compiler.cfg.intrinsics.alien
     [ second class>> fixnum class<= ]
     bi and ;
 
-: prepare-alien-accessor ( info -- offset-vreg )
+: prepare-alien-accessor ( info -- ptr-vreg offset )
-    class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+    class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
 
-: prepare-alien-getter ( infos -- offset-vreg )
+: prepare-alien-getter ( infos -- ptr-vreg offset )
     first prepare-alien-accessor ;
 
 : inline-alien-getter ( node quot -- )
@@ -49,7 +49,7 @@ IN: compiler.cfg.intrinsics.alien
     [ third class>> fixnum class<= ]
     tri and and ;
 
-: prepare-alien-setter ( infos -- offset-vreg )
+: prepare-alien-setter ( infos -- ptr-vreg offset )
     second prepare-alien-accessor ;
 
 : inline-alien-integer-setter ( node quot -- )

basis/compiler/cfg/representations/representations.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators make locals deques dlists layouts
+arrays combinators combinators.short-circuit make locals deques
-cpu.architecture compiler.utilities
+dlists layouts cpu.architecture compiler.utilities
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.hats
@@ -96,9 +96,8 @@ SYMBOL: always-boxed
     H{ } clone [
         '[
             [
-                dup ##load-reference? [ drop ] [
+                dup [ ##load-reference? ] [ ##load-constant? ] bi or
-                    [ _ (compute-always-boxed) ] each-def-rep
+                [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
-                ] if
             ] each-non-phi
         ] each-basic-block
     ] keep ;
@@ -209,6 +208,25 @@ SYMBOL: phi-mappings
 M: ##phi conversions-for-insn
     [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
 
+! When a literal zero vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } = ]
+    } 1&& ;
+
+: convert-to-zero-vector ( insn -- )
+    dst>> dup rep-of ##zero-vector ;
+
+M: ##load-reference conversions-for-insn
+    dup convert-to-zero-vector?
+    [ convert-to-zero-vector ] [ call-next-method ] if ;
+
+M: ##load-constant conversions-for-insn
+    dup convert-to-zero-vector?
+    [ convert-to-zero-vector ] [ call-next-method ] if ;
+
 M: vreg-insn conversions-for-insn
     [ compute-renaming-set ] [ perform-renaming ] bi ;
 

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -14,10 +14,10 @@ C: <constant> constant-expr
 
 M: constant-expr equal?
     over constant-expr? [
-        {
+        [ value>> ] bi@
-            [ [ value>> class ] bi@ = ]
+        2dup [ float? ] both? [ fp-bitwise= ] [
-            [ [ value>> ] bi@ = ]
+            { [ [ class ] bi@ = ] [ = ] } 2&&
-        } 2&&
+        ] if
     ] [ 2drop f ] if ;
 
 TUPLE: reference-expr < expr value ;
@@ -25,13 +25,7 @@ TUPLE: reference-expr < expr value ;
 C: <reference> reference-expr
 
 M: reference-expr equal?
-    over reference-expr? [
+    over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
-        [ value>> ] bi@ {
-            { [ 2dup eq? ] [ 2drop t ] }
-            { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
-            [ 2drop f ]
-        } cond
-    ] [ 2drop f ] if ;
 
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
@@ -43,6 +37,8 @@ M: ##load-immediate >expr val>> <constant> ;
 
 M: ##load-reference >expr obj>> <reference> ;
 
+M: ##load-constant >expr obj>> <constant> ;
+
 <<
 
 : input-values ( slot-specs -- slot-specs' )

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes vectors locals make
+math.bitwise math.order math.vectors.simd.intrinsics classes
+vectors locals make alien.c-types io.binary grouping
 compiler.cfg
 compiler.cfg.registers
 compiler.cfg.comparisons
@@ -15,6 +16,7 @@ IN: compiler.cfg.value-numbering.rewrite
 : vreg-small-constant? ( vreg -- ? )
     vreg>expr {
         [ constant-expr? ]
+        [ value>> fixnum? ]
         [ value>> small-enough? ]
     } 1&& ;
 
@@ -184,7 +186,7 @@ M: ##compare-branch rewrite
 : >boolean-insn ( insn ? -- insn' )
     [ dst>> ] dip
     {
-        { t [ t \ ##load-reference new-insn ] }
+        { t [ t \ ##load-constant new-insn ] }
         { f [ \ f tag-number \ ##load-immediate new-insn ] }
     } case ;
 
@@ -258,16 +260,23 @@ M: ##sub-imm rewrite
         [ sub-imm>add-imm ]
     } cond ;
 
-: strength-reduce-mul ( insn -- insn' )
+: mul-to-neg? ( insn -- ? )
-    [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+    src2>> -1 = ;
 
-: strength-reduce-mul? ( insn -- ? )
+: mul-to-neg ( insn -- insn' )
+    [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
+
+: mul-to-shl? ( insn -- ? )
     src2>> power-of-2? ;
 
+: mul-to-shl ( insn -- insn' )
+    [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
 M: ##mul-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
+        { [ dup mul-to-neg? ] [ mul-to-neg ] }
+        { [ dup mul-to-shl? ] [ mul-to-shl ] }
         { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
         [ drop f ]
     } cond ;
@@ -338,8 +347,15 @@ M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
 : rewrite-subtraction-identity ( insn -- insn' )
     dst>> 0 \ ##load-immediate new-insn ;
 
+: sub-to-neg? ( ##sub -- ? )
+    src1>> vn>expr expr-zero? ;
+
+: sub-to-neg ( ##sub -- insn )
+    [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
 M: ##sub rewrite
     {
+        { [ dup sub-to-neg? ] [ sub-to-neg ] }
         { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
         [ \ ##sub-imm rewrite-arithmetic ]
     } cond ;
@@ -375,3 +391,71 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
 M: ##unbox-any-c-ptr rewrite
     dup src>> vreg>expr dup box-displaced-alien-expr?
     [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
+
+! More efficient addressing for alien intrinsics
+: rewrite-alien-addressing ( insn -- insn' )
+    dup src>> vreg>expr dup add-imm-expr? [
+        [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
+        [ >>src ] [ '[ _ + ] change-offset ] bi*
+    ] [ 2drop f ] if ;
+
+M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
+M: ##alien-float rewrite rewrite-alien-addressing ;
+M: ##alien-double rewrite rewrite-alien-addressing ;
+M: ##alien-vector rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
+M: ##set-alien-float rewrite rewrite-alien-addressing ;
+M: ##set-alien-double rewrite rewrite-alien-addressing ;
+M: ##set-alien-vector rewrite rewrite-alien-addressing ;
+
+! Some lame constant folding for SIMD intrinsics. Eventually this
+! should be redone completely.
+
+: rewrite-shuffle-vector ( insn expr -- insn' )
+    2dup [ rep>> ] bi@ eq? [
+        [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+        [ [ shuffle>> ] bi@ nths ]
+        [ drop rep>> ]
+        2tri \ ##shuffle-vector new-insn
+    ] [ 2drop f ] if ;
+
+: (fold-shuffle-vector) ( shuffle bytes -- bytes' )
+    2dup length swap length /i group nths concat ;
+
+: fold-shuffle-vector ( insn expr -- insn' )
+    [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+    (fold-shuffle-vector) \ ##load-constant new-insn ;
+
+M: ##shuffle-vector rewrite
+    dup src>> vreg>expr {
+        { [ dup shuffle-vector-expr? ] [ rewrite-shuffle-vector ] }
+        { [ dup reference-expr? ] [ fold-shuffle-vector ] }
+        { [ dup constant-expr? ] [ fold-shuffle-vector ] }
+        [ 2drop f ]
+    } cond ;
+
+: (fold-scalar>vector) ( insn bytes -- insn' )
+    [ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
+    \ ##load-constant new-insn ;
+
+: fold-scalar>vector ( insn expr -- insn' )
+    value>> over rep>> {
+        { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
+        { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
+        [ rep-component-type heap-size >le (fold-scalar>vector) ]
+    } case ;
+
+M: ##scalar>vector rewrite
+    dup src>> vreg>expr dup constant-expr?
+    [ fold-scalar>vector ] [ 2drop f ] if ;
+
+M: ##xor-vector rewrite
+    dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+    [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators classes math layouts
+sequences math.vectors.simd.intrinsics
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions ;
@@ -22,6 +23,22 @@ M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
 
 : expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
 
+: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
+
+: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
+
+M: neg-expr simplify*
+    >unary-expr< {
+        { [ dup neg-expr? ] [ src>> ] }
+        [ drop f ]
+    } cond ;
+
+M: not-expr simplify*
+    >unary-expr< {
+        { [ dup not-expr? ] [ src>> ] }
+        [ drop f ]
+    } cond ;
+
 : >binary-expr< ( expr -- in1 in2 )
     [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
 
@@ -113,6 +130,16 @@ M: box-displaced-alien-expr simplify*
         [ 2drop f ]
     } cond ;
 
+M: scalar>vector-expr simplify*
+    src>> vn>expr {
+        { [ dup vector>scalar-expr? ] [ src>> ] }
+        [ drop f ]
+    } cond ;
+
+M: shuffle-vector-expr simplify*
+    [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
+    sequence= [ drop f ] unless ;
+
 M: expr simplify* drop f ;
 
 : simplify ( expr -- vn )

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -20,15 +20,15 @@ IN: compiler.cfg.value-numbering.tests
 ! Folding constants together
 [
     {
-        T{ ##load-reference f 0 0.0 }
+        T{ ##load-constant f 0 0.0 }
-        T{ ##load-reference f 1 -0.0 }
+        T{ ##load-constant f 1 -0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-reference f 0 0.0 }
+        T{ ##load-constant f 0 0.0 }
-        T{ ##load-reference f 1 -0.0 }
+        T{ ##load-constant f 1 -0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
@@ -36,15 +36,15 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-reference f 0 0.0 }
+        T{ ##load-constant f 0 0.0 }
         T{ ##copy f 1 0 any-rep }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-reference f 0 0.0 }
+        T{ ##load-constant f 0 0.0 }
-        T{ ##load-reference f 1 0.0 }
+        T{ ##load-constant f 1 0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
@@ -52,15 +52,15 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-reference f 0 t }
+        T{ ##load-constant f 0 t }
         T{ ##copy f 1 0 any-rep }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-reference f 0 t }
+        T{ ##load-constant f 0 t }
-        T{ ##load-reference f 1 t }
+        T{ ##load-constant f 1 t }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
@@ -236,6 +236,78 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 -1 }
+        T{ ##neg f 2 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 -1 }
+        T{ ##mul f 2 0 1 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 -1 }
+        T{ ##neg f 2 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 -1 }
+        T{ ##mul f 2 1 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 0 }
+        T{ ##neg f 2 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 0 }
+        T{ ##sub f 2 1 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 0 }
+        T{ ##neg f 2 0 }
+        T{ ##copy f 3 0 any-rep }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-immediate f 1 0 }
+        T{ ##sub f 2 1 0 }
+        T{ ##sub f 3 1 2 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 1 0 }
+        T{ ##copy f 2 0 any-rep }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 1 0 }
+        T{ ##not f 2 1 }
+    } value-numbering-step
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -334,6 +406,20 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare f 2 0 1 cc= }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare f 2 0 1 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -362,6 +448,20 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare-branch f 0 1 cc= }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare-branch f 0 1 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -947,7 +1047,7 @@ cell 8 = [
     {
         T{ ##load-immediate f 1 1 }
         T{ ##load-immediate f 2 2 }
-        T{ ##load-reference f 3 t }
+        T{ ##load-constant f 3 t }
     }
 ] [
     {
@@ -961,7 +1061,7 @@ cell 8 = [
     {
         T{ ##load-immediate f 1 1 }
         T{ ##load-immediate f 2 2 }
-        T{ ##load-reference f 3 t }
+        T{ ##load-constant f 3 t }
     }
 ] [
     {
@@ -1000,7 +1100,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
+        T{ ##load-constant f 1 t }
     }
 ] [
     {
@@ -1024,7 +1124,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
+        T{ ##load-constant f 1 t }
     }
 ] [
     {
@@ -1048,7 +1148,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
+        T{ ##load-constant f 1 t }
     }
 ] [
     {
@@ -1057,6 +1157,76 @@ cell 8 = [
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##vector>scalar f 1 0 float-4-rep }
+        T{ ##copy f 2 0 any-rep }
+    }
+] [
+    {
+        T{ ##vector>scalar f 1 0 float-4-rep }
+        T{ ##scalar>vector f 2 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##copy f 1 0 any-rep }
+    }
+] [
+    {
+        T{ ##shuffle-vector f 1 0 { 0 1 2 3 } float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+        T{ ##shuffle-vector f 2 0 { 0 2 3 1 } float-4-rep }
+    }
+] [
+    {
+        T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+        T{ ##shuffle-vector f 2 1 { 3 1 2 0 } float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+        T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+    }
+] [
+    {
+        T{ ##shuffle-vector f 1 0 { 1 2 3 0 } float-4-rep }
+        T{ ##shuffle-vector f 2 1 { 1 0 } double-2-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-constant f 0 1.25 }
+        T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    {
+        T{ ##load-constant f 0 1.25 }
+        T{ ##scalar>vector f 1 0 float-4-rep }
+        T{ ##shuffle-vector f 2 1 { 0 0 0 0 } float-4-rep }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##zero-vector f 2 float-4-rep }
+    }
+] [
+    {
+        T{ ##xor-vector f 2 1 1 float-4-rep }
+    } value-numbering-step
+] unit-test
+
 : test-branch-folding ( insns -- insns' n )
     <basic-block>
     [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
@@ -1203,7 +1373,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
+        T{ ##load-constant f 1 t }
         T{ ##branch }
     }
     0

basis/compiler/codegen/codegen.factor

@@ -110,6 +110,7 @@ SYNTAX: CODEGEN:
 
 CODEGEN: ##load-immediate %load-immediate
 CODEGEN: ##load-reference %load-reference
+CODEGEN: ##load-constant %load-reference
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
 CODEGEN: ##inc-d %inc-d

basis/compression/lzw/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Keith Lazuka

basis/compression/lzw/lzw-docs.factor

@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Keith Lazuka
+! See http://factorcode.org/license.txt for BSD license.
+USING: bitstreams byte-arrays classes help.markup help.syntax
+kernel math quotations sequences ;
+IN: compression.lzw
+
+HELP: gif-lzw-uncompress
+{ $values
+    { "seq" sequence } { "code-size" integer }
+    { "byte-array" byte-array }
+}
+{ $description "Decompresses a sequence of LZW-compressed bytes obtained from a GIF file." } ;
+
+HELP: tiff-lzw-uncompress
+{ $values
+    { "seq" sequence }
+    { "byte-array" byte-array }
+}
+{ $description "Decompresses a sequence of LZW-compressed bytes obtained from a TIFF file." } ;
+
+HELP: lzw-read
+{ $values
+    { "lzw" lzw }
+    { "lzw" lzw } { "n" integer }
+}
+{ $description "Read the next LZW code." } ;
+
+HELP: lzw-process-next-code
+{ $values
+    { "lzw" lzw } { "quot" quotation }
+}
+{ $description "Read the next LZW code and, assuming that the code is neither the Clear Code nor the End of Information Code, conditionally processes it by calling " { $snippet "quot" } " with the lzw object and the LZW code. If it does read a Clear Code, this combinator will take care of handling the Clear Code for you." } ;
+
+HELP: <lzw-uncompress>
+{ $values
+    { "input" bit-reader } { "code-size" "number of bits" } { "class" class }
+    { "obj" object }
+}
+{ $description "Instantiate a new LZW decompressor." } ;
+
+HELP: code-space-full?
+{ $values
+    { "lzw" lzw }
+    { "?" boolean }
+}
+{ $description "Determines when to increment the variable length code's bit-width." } ;
+
+HELP: reset-lzw-uncompress
+{ $values
+    { "lzw" lzw }
+    { "lzw" lzw }
+}
+{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
+
+ARTICLE: "compression.lzw.differences" "LZW Differences between TIFF and GIF"
+{ $vocab-link "compression.lzw" }
+$nl
+"There are some subtle differences between the LZW algorithm used by TIFF and GIF images."
+{ $heading "Variable Length Codes" }
+"Both TIFF and GIF use a variation of the LZW algorithm that uses variable length codes. In both cases, the maximum code size is 12 bits. The initial code size, however, is different between the two formats. TIFF's initial code size is always 9 bits. GIF's initial code size is specified on a per-file basis at the beginning of the image descriptor block, with a minimum of 3 bits."
+$nl
+"TIFF and GIF each switch to the next code size using slightly different algorithms. GIF increments the code size as soon as the LZW string table's length is equal to 2**code-size, while TIFF increments the code size when the table's length is equal to 2**code-size - 1."
+{ $heading "Packing Bits into Bytes" }
+"TIFF and GIF LZW algorithms differ in how they pack the code bits into the byte stream. The least significant bit in a TIFF code is stored in the most significant bit of the bytestream, while the least significant bit in a GIF code is stored in the least significant bit of the bytestream."
+{ $heading "Special Codes" }
+"TIFF and GIF both add the concept of a 'Clear Code' and a 'End of Information Code' to the LZW algorithm. In both cases, the 'Clear Code' is equal to 2**(code-size - 1) and the 'End of Information Code' is equal to the Clear Code + 1. These 2 codes are reserved in the string table. So in both cases, the LZW string table is initialized to have a length equal to the End of Information Code + 1."
+;
+
+ARTICLE: "compression.lzw" "LZW Compression"
+{ $vocab-link "compression.lzw" }
+$nl
+"Implements both the TIFF and GIF variations of the LZW algorithm."
+{ $heading "Decompression" }
+{ $subsection tiff-lzw-uncompress }
+{ $subsection gif-lzw-uncompress }
+{ $heading "Compression" }
+"Compression has not yet been implemented."
+$nl
+"Implementation details:"
+{ $subsection "compression.lzw.differences" }
+;
+
+ABOUT: "compression.lzw"

basis/compression/lzw/lzw.factor

@@ -1,39 +1,37 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors assocs byte-arrays combinators
+USING: accessors combinators io kernel math namespaces
-io.encodings.binary io.streams.byte-array kernel math sequences
+prettyprint sequences vectors ;
-vectors ;
+QUALIFIED-WITH: bitstreams bs
 IN: compression.lzw
 
-QUALIFIED-WITH: bitstreams bs
+TUPLE: lzw
+input
+output
+table
+code
+old-code
+initial-code-size
+code-size
+clear-code
+end-of-information-code ;
 
-CONSTANT: clear-code 256
+TUPLE: tiff-lzw < lzw ;
-CONSTANT: end-of-information 257
+TUPLE: gif-lzw < lzw ;
 
-TUPLE: lzw input output table code old-code ;
+: initial-uncompress-table ( size -- seq )
-
+    iota [ 1vector ] V{ } map-as ;
-SYMBOL: table-full
-
-: lzw-bit-width ( n -- n' )
-    {
-        { [ dup 510 <= ] [ drop 9 ] }
-        { [ dup 1022 <= ] [ drop 10 ] }
-        { [ dup 2046 <= ] [ drop 11 ] }
-        { [ dup 4094 <= ] [ drop 12 ] }
-        [ drop table-full ]
-    } cond ;
-
-: lzw-bit-width-uncompress ( lzw -- n )
-    table>> length lzw-bit-width ;
-
-: initial-uncompress-table ( -- seq )
-    258 iota [ 1vector ] V{ } map-as ;
 
 : reset-lzw-uncompress ( lzw -- lzw )
-    initial-uncompress-table >>table ;
+    dup end-of-information-code>> 1 + initial-uncompress-table >>table
+    dup initial-code-size>> >>code-size ;
 
-: <lzw-uncompress> ( input -- obj )
+: <lzw-uncompress> ( input code-size class -- obj )
-    lzw new
+    new
+        swap >>code-size
+        dup code-size>> >>initial-code-size
+        dup code-size>> 1 - 2^ >>clear-code
+        dup clear-code>> 1 + >>end-of-information-code
         swap >>input
         BV{ } clone >>output
         reset-lzw-uncompress ;
@@ -55,22 +53,43 @@ ERROR: not-in-table value ;
 : write-code ( lzw -- )
     [ lookup-code ] [ output>> ] bi push-all ;
 
-: add-to-table ( seq lzw -- ) table>> push ;
+GENERIC: code-space-full? ( lzw -- ? )
+
+: size-and-limit ( lzw -- m n ) [ table>> length ] [ code-size>> 2^ ] bi ;
+
+M: tiff-lzw code-space-full? size-and-limit 1 - = ;
+M: gif-lzw code-space-full? size-and-limit = ;
+
+: maybe-increment-code-size ( lzw -- lzw )
+    dup code-space-full? [ [ 1 + ] change-code-size ] when ;
+
+: add-to-table ( seq lzw -- )
+    [ table>> push ]
+    [ maybe-increment-code-size 2drop ] 2bi ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
+    [ ] [ code-size>> ] [ input>> ] tri bs:read ;
+
+: end-of-information? ( lzw code -- ? ) swap end-of-information-code>> = ;
+: clear-code? ( lzw code -- ? ) swap clear-code>> = ;
+
+DEFER: handle-clear-code
+: lzw-process-next-code ( lzw quot: ( lzw code -- ) -- )
+    [ lzw-read ] dip {
+        { [ 3dup drop end-of-information? ] [ 3drop ] }
+        { [ 3dup drop clear-code? ] [ 2drop handle-clear-code ] }
+        [ call( lzw code -- ) ]
+    } cond ; inline
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )
     reset-lzw-uncompress
-    lzw-read dup end-of-information = [
+    [
-        2drop
-    ] [
         >>code
         [ write-code ]
         [ code>old-code ] bi
         lzw-uncompress-char
-    ] if ;
+    ] lzw-process-next-code ;
 
 : handle-uncompress-code ( lzw -- lzw )
     dup code-in-table? [
@@ -89,23 +108,15 @@ DEFER: lzw-uncompress-char
     ] if ;
     
 : lzw-uncompress-char ( lzw -- )
-    lzw-read [
+    [ >>code handle-uncompress-code lzw-uncompress-char ]
-        >>code
+    lzw-process-next-code ;
-        dup code>> end-of-information = [
-            drop
-        ] [
-            dup code>> clear-code = [
-                handle-clear-code
-            ] [
-                handle-uncompress-code
-                lzw-uncompress-char
-            ] if
-        ] if
-    ] [
-        drop
-    ] if* ;
 
-: lzw-uncompress ( seq -- byte-array )
+: lzw-uncompress ( bitstream code-size class -- byte-array )
-    bs:<msb0-bit-reader>
     <lzw-uncompress>
     [ lzw-uncompress-char ] [ output>> ] bi ;
+
+: tiff-lzw-uncompress ( seq -- byte-array )
+    bs:<msb0-bit-reader> 9 tiff-lzw lzw-uncompress ;
+
+: gif-lzw-uncompress ( seq code-size -- byte-array )
+    [ bs:<lsb0-bit-reader> ] dip gif-lzw lzw-uncompress ;

basis/cpu/architecture/architecture.factor

@@ -114,6 +114,14 @@ M: float-rep rep-size drop 4 ;
 M: double-rep rep-size drop 8 ;
 M: stack-params rep-size drop cell ;
 M: vector-rep rep-size drop 16 ;
+M: char-scalar-rep rep-size drop 1 ;
+M: uchar-scalar-rep rep-size drop 1 ;
+M: short-scalar-rep rep-size drop 2 ;
+M: ushort-scalar-rep rep-size drop 2 ;
+M: int-scalar-rep rep-size drop 4 ;
+M: uint-scalar-rep rep-size drop 4 ;
+M: longlong-scalar-rep rep-size drop 8 ;
+M: ulonglong-scalar-rep rep-size drop 8 ;
 
 GENERIC: rep-component-type ( rep -- n )
 
@@ -277,24 +285,24 @@ HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
 
-HOOK: %alien-unsigned-1 cpu ( dst src -- )
+HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-2 cpu ( dst src -- )
+HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-4 cpu ( dst src -- )
+HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
-HOOK: %alien-signed-1   cpu ( dst src -- )
+HOOK: %alien-signed-1   cpu ( dst src offset -- )
-HOOK: %alien-signed-2   cpu ( dst src -- )
+HOOK: %alien-signed-2   cpu ( dst src offset -- )
-HOOK: %alien-signed-4   cpu ( dst src -- )
+HOOK: %alien-signed-4   cpu ( dst src offset -- )
-HOOK: %alien-cell       cpu ( dst src -- )
+HOOK: %alien-cell       cpu ( dst src offset -- )
-HOOK: %alien-float      cpu ( dst src -- )
+HOOK: %alien-float      cpu ( dst src offset -- )
-HOOK: %alien-double     cpu ( dst src -- )
+HOOK: %alien-double     cpu ( dst src offset -- )
-HOOK: %alien-vector     cpu ( dst src rep -- )
+HOOK: %alien-vector     cpu ( dst src offset rep -- )
 
-HOOK: %set-alien-integer-1 cpu ( ptr value -- )
+HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
-HOOK: %set-alien-cell      cpu ( ptr value -- )
+HOOK: %set-alien-cell      cpu ( ptr offset value -- )
-HOOK: %set-alien-float     cpu ( ptr value -- )
+HOOK: %set-alien-float     cpu ( ptr offset value -- )
-HOOK: %set-alien-double    cpu ( ptr value -- )
+HOOK: %set-alien-double    cpu ( ptr offset value -- )
-HOOK: %set-alien-vector    cpu ( ptr value rep -- )
+HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
 HOOK: %vm-field-ptr cpu ( dst fieldname -- )

basis/cpu/x86/x86.factor

@@ -307,45 +307,45 @@ M:: x86 %set-string-nth-fast ( ch str index temp -- )
         temp string-offset [+] new-ch 8-bit-version-of MOV
     ] with-small-register ;
 
-:: %alien-integer-getter ( dst src size quot -- )
+:: %alien-integer-getter ( dst src offset size quot -- )
     dst { src } size [| new-dst |
-        new-dst dup size n-bit-version-of dup src [] MOV
+        new-dst dup size n-bit-version-of dup src offset [+] MOV
         quot call
         dst new-dst int-rep %copy
     ] with-small-register ; inline
 
-: %alien-unsigned-getter ( dst src size -- )
+: %alien-unsigned-getter ( dst src offset size -- )
     [ MOVZX ] %alien-integer-getter ; inline
 
 M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
 M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
 M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
 
-: %alien-signed-getter ( dst src size -- )
+: %alien-signed-getter ( dst src offset size -- )
     [ MOVSX ] %alien-integer-getter ; inline
 
 M: x86 %alien-signed-1 8 %alien-signed-getter ;
 M: x86 %alien-signed-2 16 %alien-signed-getter ;
 M: x86 %alien-signed-4 32 %alien-signed-getter ;
 
-M: x86 %alien-cell [] MOV ;
+M: x86 %alien-cell [+] MOV ;
-M: x86 %alien-float [] MOVSS ;
+M: x86 %alien-float [+] MOVSS ;
-M: x86 %alien-double [] MOVSD ;
+M: x86 %alien-double [+] MOVSD ;
-M: x86 %alien-vector [ [] ] dip %copy ;
+M: x86 %alien-vector [ [+] ] dip %copy ;
 
-:: %alien-integer-setter ( ptr value size -- )
+:: %alien-integer-setter ( ptr offset value size -- )
     value { ptr } size [| new-value |
         new-value value int-rep %copy
-        ptr [] new-value size n-bit-version-of MOV
+        ptr offset [+] new-value size n-bit-version-of MOV
     ] with-small-register ; inline
 
 M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
 M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
 M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [] ] dip MOV ;
+M: x86 %set-alien-cell [ [+] ] dip MOV ;
-M: x86 %set-alien-float [ [] ] dip MOVSS ;
+M: x86 %set-alien-float [ [+] ] dip MOVSS ;
-M: x86 %set-alien-double [ [] ] dip MOVSD ;
+M: x86 %set-alien-double [ [+] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [] ] 2dip %copy ;
+M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
 
 : shift-count? ( reg -- ? ) { ECX RCX } memq? ;
 
@@ -1042,8 +1042,11 @@ M: x86 %shr-vector-reps
         { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
     } available-reps ;
 
-M: x86 %integer>scalar drop MOVD ;
+: scalar-sized-reg ( reg rep -- reg' )
-M: x86 %scalar>integer drop MOVD ;
+    rep-size 8 * n-bit-version-of ;
+
+M: x86 %integer>scalar scalar-sized-reg MOVD ;
+M: x86 %scalar>integer swap [ scalar-sized-reg ] dip MOVD ;
 M: x86 %vector>scalar %copy ;
 M: x86 %scalar>vector %copy ;
 

basis/help/markup/markup.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes colors.constants
+USING: accessors arrays assocs classes colors colors.constants
 combinators definitions definitions.icons effects fry generic
 hashtables help.stylesheet help.topics io io.styles kernel make
 math namespaces parser present prettyprint
@@ -154,6 +154,9 @@ ALIAS: $slot $snippet
     1array \ $image prefix ;
 
 ! Some links
+
+<PRIVATE
+
 : write-link ( string object -- )
     link-style get [ write-object ] with-style ;
 
@@ -163,38 +166,35 @@ ALIAS: $slot $snippet
 : link-text ( topic -- )
     [ article-name ] keep write-link ;
 
-: link-effect ( topic -- )
+GENERIC: link-long-text ( topic -- )
-    dup word? [
-        stack-effect [ effect>string ] [ effect-style ] bi
-        [ write ] with-style
-    ] [ drop ] if ;
 
-: inter-cleave ( x seq between -- )
+M: topic link-long-text
-    [ [ call( x -- ) ] with ] dip swap interleave ; inline
+    [ article-title ] keep write-link ;
 
-: (($link)) ( topic words -- )
+M: word link-long-text
-    [ dup topic? [ >link ] unless ] dip
+    dup presented associate [
-    [ [ bl ] inter-cleave ] ($span) ; inline
+        [ article-name link-style get format ]
+        [ drop bl ]
+        [ stack-effect effect>string stack-effect-style get format ]
+        tri
+    ] with-nesting ;
 
-: ($link) ( topic -- )
+: >topic ( obj -- topic ) dup topic? [ >link ] unless ;
-    { [ link-text ] } (($link)) ;
 
+PRIVATE>
+
+: ($link) ( topic -- ) >topic link-text ;
 : $link ( element -- ) first ($link) ;
 
-: ($long-link) ( topic -- )
+: ($long-link) ( topic -- ) >topic link-long-text ;
-    { [ link-text ] [ link-effect ] } (($link)) ;
-
 : $long-link ( element -- ) first ($long-link) ;
 
 : ($pretty-link) ( topic -- )
-    { [ link-icon ] [ link-text ] } (($link)) ;
+    >topic [ link-icon ] [ drop bl ] [ link-text ] tri ;
-
 : $pretty-link ( element -- ) first ($pretty-link) ;
 
 : ($long-pretty-link) ( topic -- )
-    { [ link-icon ] [ link-text ] [ link-effect ] } (($link)) ;
+    >topic [ link-icon ] [ drop bl ] [ link-long-text ] tri ;
-
-: $long-pretty-link ( element -- ) first ($long-pretty-link) ;
 
 : <$pretty-link> ( definition -- element )
     1array \ $pretty-link prefix ;

basis/images/tiff/tiff-tests.factor

@@ -1,10 +1,44 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test images.tiff ;
+USING: accessors images.tiff images.viewer io
+io.encodings.binary io.files namespaces sequences tools.test ;
 IN: images.tiff.tests
 
-: tiff-test-path ( -- path )
+: path>tiff ( path -- tiff )
-    "resource:extra/images/test-images/rgb.tiff" ;
+    binary [ input-stream get load-tiff ] with-file-reader ;
+
+: tiff-example1 ( -- tiff )
+    "resource:extra/images/testing/square.tiff" path>tiff ;
+
+: tiff-example2 ( -- tiff )
+    "resource:extra/images/testing/cube.tiff" path>tiff ;
+
+: tiff-example3 ( -- tiff )
+    "resource:extra/images/testing/bi.tiff" path>tiff ;
+
+: tiff-example4 ( -- tiff )
+    "resource:extra/images/testing/noise.tiff" path>tiff ;
+
+: tiff-example5 ( -- tiff )
+    "resource:extra/images/testing/alpha.tiff" path>tiff ;
+
+: tiff-example6 ( -- tiff )
+    "resource:extra/images/testing/color_spectrum.tiff" path>tiff ;
+
+: tiff-example7 ( -- tiff )
+    "resource:extra/images/testing/small.tiff" path>tiff ;
+
+: tiff-all. ( -- )
+    {
+        tiff-example1 tiff-example2 tiff-example3 tiff-example4 tiff-example5
+        tiff-example6
+    }
+    [ execute( -- gif ) tiff>image image. ] each ;
+
+[ 1024 ] [ tiff-example1 ifds>> first bitmap>> length ] unit-test
+[ 1024 ] [ tiff-example2 ifds>> first bitmap>> length ] unit-test
+[ 131744 ] [ tiff-example3 ifds>> first bitmap>> length ] unit-test
+[ 49152 ] [ tiff-example4 ifds>> first bitmap>> length ] unit-test
+[ 16 ] [ tiff-example5 ifds>> first bitmap>> length ] unit-test
+[ 117504 ] [ tiff-example6 ifds>> first bitmap>> length ] unit-test
 
-: tiff-test-path2 ( -- path )
-    "resource:extra/images/test-images/octagon.tiff" ;

basis/images/tiff/tiff.factor

@@ -438,7 +438,7 @@ ERROR: unhandled-compression compression ;
 : (uncompress-strips) ( strips compression -- uncompressed-strips )
     {
         { compression-none [ ] }
-        { compression-lzw [ [ lzw-uncompress ] map ] }
+        { compression-lzw [ [ tiff-lzw-uncompress ] map ] }
         [ unhandled-compression ]
     } case ;
 

basis/io/styles/styles.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io io.streams.plain io.streams.string
+USING: accessors assocs colors colors.constants delegate
-colors summary make accessors splitting math.order
+delegate.protocols destructors fry hashtables io
-kernel namespaces assocs destructors strings sequences
+io.streams.plain io.streams.string kernel make math.order
-present fry strings.tables delegate delegate.protocols ;
+namespaces present sequences splitting strings strings.tables
+summary ;
 IN: io.styles
 
 GENERIC: stream-format ( str style stream -- )
@@ -162,3 +163,9 @@ M: input summary
 : write-object ( str obj -- ) presented associate format ;
 
 : write-image ( image -- ) [ "" ] dip image associate format ;
+
+SYMBOL: stack-effect-style
+H{
+    { foreground COLOR: FactorDarkGreen }
+    { font-style plain }
+} stack-effect-style set-global

basis/prettyprint/stylesheet/stylesheet.factor

@@ -43,5 +43,4 @@ PRIVATE>
     dim-color colored-presentation-style ;
 
 : effect-style ( effect -- style )
-    0 0.2 0 1 <rgba> colored-presentation-style
+    presented associate stack-effect-style get assoc-union ;
-    { { font-style plain } } assoc-union ;

extra/images/gif/authors.txt

@@ -0,0 +1,2 @@
+Doug Coleman
+Keith Lazuka

extra/images/gif/gif-docs.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences ;
+IN: images.gif
+
+ARTICLE: "images.gif" "GIF Image Loader"
+{ $vocab-link "images.gif" }
+$nl
+{ $notes "Currently multi-frame GIF images are not supported." }
+;
+
+ABOUT: "images.gif"

extra/images/gif/gif-tests.factor

@@ -0,0 +1,95 @@
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors bitstreams compression.lzw images.gif io
+io.encodings.binary io.files kernel math math.bitwise
+math.parser namespaces prettyprint sequences tools.test images.viewer ;
+QUALIFIED-WITH: bitstreams bs
+IN: images.gif.tests
+
+: path>gif ( path -- loading-gif )
+    binary [ input-stream get load-gif ] with-file-reader ;
+
+: gif-example1 ( -- loading-gif )
+    "resource:extra/images/testing/circle.gif" path>gif ;
+
+: gif-example2 ( -- loading-gif )
+    "resource:extra/images/testing/checkmark.gif" path>gif ;
+
+: gif-example3 ( -- loading-gif )
+    "resource:extra/images/testing/monochrome.gif" path>gif ;
+
+: gif-example4 ( -- loading-gif )
+    "resource:extra/images/testing/noise.gif" path>gif ;
+
+: gif-example5 ( -- loading-gif )
+    "resource:extra/images/testing/alpha.gif" path>gif ;
+
+: gif-example6 ( -- loading-gif )
+    "resource:extra/images/testing/astronaut_animation.gif" path>gif ;
+
+: gif-all. ( -- )
+    {
+        gif-example1 gif-example2 gif-example3 gif-example4 gif-example5
+        gif-example6
+    }
+    [ execute( -- gif ) gif>image image. ] each ;
+
+: declared-num-colors ( gif -- n ) flags>> 3 bits 1 + 2^ ;
+: actual-num-colors ( gif -- n ) global-color-table>> length ;
+
+[ 16 ] [ gif-example1 actual-num-colors ] unit-test
+[ 16 ] [ gif-example1 declared-num-colors ] unit-test
+
+[ 256 ] [ gif-example2 actual-num-colors ] unit-test
+[ 256 ] [ gif-example2 declared-num-colors ] unit-test
+
+[ 2 ] [ gif-example3 actual-num-colors ] unit-test
+[ 2 ] [ gif-example3 declared-num-colors ] unit-test
+
+: >index-stream ( gif -- seq )
+    [ compressed-bytes>> ]
+    [ image-descriptor>> first-code-size>> ] bi
+    gif-lzw-uncompress ;
+
+[
+    BV{
+        0 0 0 0 0 0
+        1 0 0 0 0 1
+        1 1 0 0 1 1
+        1 1 1 1 1 1
+        1 0 1 1 0 1
+        1 0 0 0 0 1
+    }
+] [ gif-example3 >index-stream ] unit-test
+
+[
+    B{
+        255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255
+        0 0 0 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 0 0 255
+        0 0 0 255 0 0 0 255 255 255 255 255 255 255 255 255 0 0 0 255 0 0 0 255
+        0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255 0 0 0 255
+        0 0 0 255 255 255 255 255 0 0 0 255 0 0 0 255 255 255 255 255 0 0 0 255
+        0 0 0 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 0 0 255
+    }
+] [ gif-example3 gif>image bitmap>> ] unit-test
+
+[
+    BV{
+        0 1
+        1 0
+    }
+] [ gif-example5 >index-stream ] unit-test
+
+[
+    B{
+        255 000 000 255     000 000 000 000
+        000 000 000 000     255 000 000 255
+    }
+] [ gif-example5 gif>image bitmap>> ] unit-test
+
+[ 100 ] [ gif-example1 >index-stream length ] unit-test
+[ 870 ] [ gif-example2 >index-stream length ] unit-test
+[ 16384 ] [ gif-example4 >index-stream length ] unit-test
+
+! example6 is a GIF animation and the first frame contains 1768 pixels
+[ 1768 ] [ gif-example6 >index-stream length ] unit-test

extra/images/gif/gif.factor

@@ -1,11 +1,11 @@
-! Copyrigt (C) 2009 Doug Coleman.
+! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators constructors destructors
+USING: accessors arrays assocs combinators compression.lzw
-images images.loader io io.binary io.buffers
+constructors destructors grouping images images.loader io
-io.encodings.binary io.encodings.string io.encodings.utf8
+io.binary io.buffers io.encodings.binary io.encodings.string
-io.files io.files.info io.ports io.streams.limited kernel make
+io.encodings.utf8 io.files io.files.info io.ports
-math math.bitwise math.functions multiline namespaces
+io.streams.limited kernel make math math.bitwise math.functions
-prettyprint sequences ;
+multiline namespaces prettyprint sequences ;
 IN: images.gif
 
 SINGLETON: gif-image
@@ -37,12 +37,10 @@ ERROR: unknown-extension n ;
 ERROR: gif-unexpected-eof ;
 
 TUPLE: graphics-control-extension
-label block-size raw-data
+flags delay-time transparent-color-index ;
-packed delay-time color-index
-block-terminator ;
 
 TUPLE: image-descriptor
-separator left top width height flags ;
+left top width height flags first-code-size ;
 
 TUPLE: plain-text-extension
 introducer label block-size text-grid-left text-grid-top text-grid-width
@@ -67,6 +65,8 @@ CONSTANT: graphic-control-extension HEX: f9
 CONSTANT: comment-extension HEX: fe
 CONSTANT: application-extension HEX: ff
 CONSTANT: trailer HEX: 3b
+CONSTANT: graphic-control-extension-block-size HEX: 04
+CONSTANT: block-terminator HEX: 00
 
 : <loading-gif> ( -- loading-gif )
     \ loading-gif new
@@ -92,18 +92,20 @@ M: input-port stream-peek1
 
 : read-image-descriptor ( -- image-descriptor )
     \ image-descriptor new
-        1 read le> >>separator
         2 read le> >>left
         2 read le> >>top
         2 read le> >>width
         2 read le> >>height
-        1 read le> >>flags ;
+        1 read le> >>flags
+        1 read le> 1 + >>first-code-size ;
 
 : read-graphic-control-extension ( -- graphic-control-extension )
     \ graphics-control-extension new
-        1 read le> [ >>block-size ] [ read ] bi
+        1 read le> graphic-control-extension-block-size assert=
-        >>raw-data
+        1 read le> >>flags
-        1 read le> >>block-terminator ;
+        2 read le> >>delay-time
+        1 read le> >>transparent-color-index
+        1 read le> block-terminator assert= ;
 
 : read-plain-text-extension ( -- plain-text-extension )
     \ plain-text-extension new
@@ -147,12 +149,14 @@ ERROR: unimplemented message ;
 : interlaced? ( image -- ? ) flags>> 6 bit? ; inline
 : sort? ( image -- ? ) flags>> 5 bit? ; inline
 : color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
+: transparency? ( image -- ? )
+    graphic-control-extensions>> first flags>> 0 bit? ; inline
 
 : color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
 
 : read-global-color-table ( loading-gif -- loading-gif )
     dup color-table? [
-        dup color-table-size read >>global-color-table
+        dup color-table-size read 3 group >>global-color-table
     ] when ;
 
 : maybe-read-local-color-table ( loading-gif -- loading-gif )
@@ -220,8 +224,33 @@ ERROR: unhandled-data byte ;
         } case
     ] with-input-stream ;
 
-: loading-gif>image ( loading-gif -- image )
+: decompress ( loading-gif -- indexes )
-    ;
+    [ compressed-bytes>> ]
+    [ image-descriptor>> first-code-size>> ] bi
+    gif-lzw-uncompress ;
+
+: colorize ( index palette transparent-index/f -- seq )
+    pick = [ 2drop B{ 0 0 0 0 } ] [ nth 255 suffix ] if ;
+
+: apply-palette ( indexes palette transparent-index/f -- bitmap )
+    [ colorize ] 2curry V{ } map-as concat ;
+
+: dimensions ( loading-gif -- dim )
+    [ image-descriptor>> width>> ] [ image-descriptor>> height>> ] bi 2array ;
+
+: ?transparent-color-index ( loading-gif -- index/f )
+    dup transparency?
+    [ graphic-control-extensions>> first transparent-color-index>> ]
+    [ drop f ] if ;
+
+: gif>image ( loading-gif -- image )
+    [ <image> ] dip
+    [ dimensions >>dim ]
+    [ drop RGBA >>component-order ubyte-components >>component-type ]
+    [
+        [ decompress ] [ global-color-table>> ] [ ?transparent-color-index ] tri
+        apply-palette >>bitmap
+    ] tri ;
 
 ERROR: loading-gif-error gif-image ;
 
@@ -229,4 +258,4 @@ ERROR: loading-gif-error gif-image ;
     dup loading?>> [ loading-gif-error ] when ;
 
 M: gif-image stream>image ( path gif-image -- image )
-    drop load-gif ensure-loaded loading-gif>image ;
+    drop load-gif ensure-loaded gif>image ;

extra/images/gif/summary.txt

@@ -0,0 +1 @@
+GIF image file format

extra/math/matrices/simd/simd.factor

@@ -20,7 +20,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
 <PRIVATE
 
 : rows ( a -- a1 a2 a3 a4 )
-    rows>> first4 ; inline
+    rows>> 4 firstn ; inline
 
 :: set-rows ( c1 c2 c3 c4 c -- c )
     c rows>> :> rows