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

Makefile

@@ -47,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/data_heap_checker.o \
 	vm/debug.o \
 	vm/dispatch.o \
+	vm/entry_points.o \
 	vm/errors.o \
 	vm/factor.o \
 	vm/free_list.o \

basis/alien/remote-control/remote-control.factor

@@ -19,8 +19,8 @@ IN: alien.remote-control
     dup optimized? [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
-    \ eval-callback ?callback 16 setenv
+    \ eval-callback ?callback 16 set-special-object
-    \ yield-callback ?callback 17 setenv
+    \ yield-callback ?callback 17 set-special-object
-    \ sleep-callback ?callback 18 setenv ;
+    \ sleep-callback ?callback 18 set-special-object ;
 
 MAIN: init-remote-control

basis/base64/base64.factor

@@ -13,7 +13,8 @@ ERROR: malformed-base64 ;
     read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
 
 : read-ignoring ( ignoring n -- str )
-    [ drop read1-ignoring ] with map harvest
+    [ drop read1-ignoring ] with { } map-integers
+    [ { f 0 } member? not ] filter
     [ f ] [ >string ] if-empty ;
 
 : ch>base64 ( ch -- ch )
@@ -42,7 +43,7 @@ SYMBOL: column
     [ write1-lines ] each ;
 
 : encode3 ( seq -- )
-    be> 4 <reversed> [
+    be> 4 iota <reversed> [
         -6 * shift HEX: 3f bitand ch>base64 write1-lines
     ] with each ; inline
 

basis/binary-search/binary-search-tests.factor

@@ -1,4 +1,4 @@
-USING: binary-search math.order vectors kernel tools.test ;
+USING: binary-search math.order sequences kernel tools.test ;
 IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
@@ -7,7 +7,7 @@ IN: binary-search.tests
 [ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
 [ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
-[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
+[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
 
 [ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
 [ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test

basis/bit-arrays/bit-arrays-tests.factor

@@ -40,7 +40,7 @@ IN: bit-arrays.tests
     100 [
         drop 100 [ 2 random zero? ] replicate
         dup >bit-array >array =
-    ] all?
+    ] all-integers?
 ] unit-test
 
 [ ?{ f } ] [

basis/bit-arrays/bit-arrays.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.data accessors math alien.accessors kernel
 kernel.private sequences sequences.private byte-arrays
@@ -25,7 +25,7 @@ TUPLE: bit-array
 
 : (set-bits) ( bit-array n -- )
     [ [ length bits>cells ] keep ] dip swap underlying>>
-    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
 
 : clean-up ( bit-array -- )
     ! Zero bits after the end.
@@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
     ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length <reversed> [
+    0 swap underlying>> dup length iota <reversed> [
         alien-unsigned-1 swap 8 shift bitor
     ] with each ;
 

basis/bit-vectors/bit-vectors-tests.factor

@@ -4,7 +4,7 @@ IN: bit-vectors.tests
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 
 : do-it ( seq -- )
-    1234 swap [ [ even? ] dip push ] curry each ;
+    1234 swap [ [ even? ] dip push ] curry each-integer ;
 
 [ t ] [
     3 <bit-vector> dup do-it

basis/bootstrap/image/image.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.strings arrays byte-arrays generic hashtables
 hashtables.private io io.binary io.files io.encodings.binary
@@ -93,7 +93,7 @@ CONSTANT: image-version 4
 
 CONSTANT: data-base 1024
 
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 70
 
 CONSTANT: header-size 10
 
@@ -155,7 +155,7 @@ SYMBOL: jit-literals
 : define-sub-primitive ( quot word -- )
     [ make-jit 3array ] dip sub-primitives get set-at ;
 
-: define-sub-primitive* ( quot non-tail-quot tail-quot word -- )
+: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
     [
         [ make-jit ]
         [ make-jit 2nip ]
@@ -176,54 +176,58 @@ SYMBOL: architecture
 RESET
 
 ! Boot quotation, set in stage1.factor
-USERENV: bootstrap-startup-quot 20
+SPECIAL-OBJECT: bootstrap-startup-quot 20
 
 ! Bootstrap global namesapce
-USERENV: bootstrap-global 21
+SPECIAL-OBJECT: bootstrap-global 21
 
 ! JIT parameters
-USERENV: jit-prolog 23
+SPECIAL-OBJECT: jit-prolog 23
-USERENV: jit-primitive-word 24
+SPECIAL-OBJECT: jit-primitive-word 24
-USERENV: jit-primitive 25
+SPECIAL-OBJECT: jit-primitive 25
-USERENV: jit-word-jump 26
+SPECIAL-OBJECT: jit-word-jump 26
-USERENV: jit-word-call 27
+SPECIAL-OBJECT: jit-word-call 27
-USERENV: jit-if-word 28
+SPECIAL-OBJECT: jit-if-word 28
-USERENV: jit-if 29
+SPECIAL-OBJECT: jit-if 29
-USERENV: jit-epilog 30
+SPECIAL-OBJECT: jit-epilog 30
-USERENV: jit-return 31
+SPECIAL-OBJECT: jit-return 31
-USERENV: jit-profiling 32
+SPECIAL-OBJECT: jit-profiling 32
-USERENV: jit-push 33
+SPECIAL-OBJECT: jit-push 33
-USERENV: jit-dip-word 34
+SPECIAL-OBJECT: jit-dip-word 34
-USERENV: jit-dip 35
+SPECIAL-OBJECT: jit-dip 35
-USERENV: jit-2dip-word 36
+SPECIAL-OBJECT: jit-2dip-word 36
-USERENV: jit-2dip 37
+SPECIAL-OBJECT: jit-2dip 37
-USERENV: jit-3dip-word 38
+SPECIAL-OBJECT: jit-3dip-word 38
-USERENV: jit-3dip 39
+SPECIAL-OBJECT: jit-3dip 39
-USERENV: jit-execute 40
+SPECIAL-OBJECT: jit-execute 40
-USERENV: jit-declare-word 41
+SPECIAL-OBJECT: jit-declare-word 41
 
-USERENV: callback-stub 48
+SPECIAL-OBJECT: c-to-factor-word 42
+SPECIAL-OBJECT: lazy-jit-compile-word 43
+SPECIAL-OBJECT: unwind-native-frames-word 44
+
+SPECIAL-OBJECT: callback-stub 48
 
 ! PIC stubs
-USERENV: pic-load 49
+SPECIAL-OBJECT: pic-load 49
-USERENV: pic-tag 50
+SPECIAL-OBJECT: pic-tag 50
-USERENV: pic-tuple 51
+SPECIAL-OBJECT: pic-tuple 51
-USERENV: pic-check-tag 52
+SPECIAL-OBJECT: pic-check-tag 52
-USERENV: pic-check-tuple 53
+SPECIAL-OBJECT: pic-check-tuple 53
-USERENV: pic-hit 54
+SPECIAL-OBJECT: pic-hit 54
-USERENV: pic-miss-word 55
+SPECIAL-OBJECT: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
+SPECIAL-OBJECT: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
-USERENV: mega-lookup 57
+SPECIAL-OBJECT: mega-lookup 57
-USERENV: mega-lookup-word 58
+SPECIAL-OBJECT: mega-lookup-word 58
-USERENV: mega-miss-word 59
+SPECIAL-OBJECT: mega-miss-word 59
 
 ! Default definition for undefined words
-USERENV: undefined-quot 60
+SPECIAL-OBJECT: undefined-quot 60
 
-: userenv-offset ( symbol -- n )
+: special-object-offset ( symbol -- n )
-    userenvs get at header-size + ;
+    special-objects get at header-size + ;
 
 : emit ( cell -- ) image get push ;
 
@@ -239,7 +243,7 @@ USERENV: undefined-quot 60
 : fixup ( value offset -- ) image get set-nth ;
 
 : heap-size ( -- size )
-    image get length header-size - userenv-size -
+    image get length header-size - special-objects-size -
     bootstrap-cells ;
 
 : here ( -- size ) heap-size data-base + ;
@@ -278,10 +282,10 @@ GENERIC: ' ( obj -- ptr )
     0 emit ! pointer to bignum 0
     0 emit ! pointer to bignum 1
     0 emit ! pointer to bignum -1
-    userenv-size [ f ' emit ] times ;
+    special-objects-size [ f ' emit ] times ;
 
-: emit-userenv ( symbol -- )
+: emit-special-object ( symbol -- )
-    [ get ' ] [ userenv-offset ] bi fixup ;
+    [ get ' ] [ special-object-offset ] bi fixup ;
 
 ! Bignums
 
@@ -534,15 +538,18 @@ M: quotation '
     \ dip jit-dip-word set
     \ 2dip jit-2dip-word set
     \ 3dip jit-3dip-word set
-    \ inline-cache-miss \ pic-miss-word set
+    \ inline-cache-miss pic-miss-word set
-    \ inline-cache-miss-tail \ pic-miss-tail-word set
+    \ inline-cache-miss-tail pic-miss-tail-word set
-    \ mega-cache-lookup \ mega-lookup-word set
+    \ mega-cache-lookup mega-lookup-word set
-    \ mega-cache-miss \ mega-miss-word set
+    \ mega-cache-miss mega-miss-word set
     \ declare jit-declare-word set
+    \ c-to-factor c-to-factor-word set
+    \ lazy-jit-compile lazy-jit-compile-word set
+    \ unwind-native-frames unwind-native-frames-word set
     [ undefined ] undefined-quot set ;
 
-: emit-userenvs ( -- )
+: emit-special-objects ( -- )
-    userenvs get keys [ emit-userenv ] each ;
+    special-objects get keys [ emit-special-object ] each ;
 
 : fixup-header ( -- )
     heap-size data-heap-size-offset fixup ;
@@ -559,8 +566,8 @@ M: quotation '
     emit-jit-data
     "Serializing global namespace..." print flush
     emit-global
-    "Serializing user environment..." print flush
+    "Serializing special object table..." print flush
-    emit-userenvs
+    emit-special-objects
     "Performing word fixups..." print flush
     fixup-words
     "Performing header fixups..." print flush

basis/bootstrap/image/syntax/syntax.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel namespaces assocs words.symbol ;
 IN: bootstrap.image.syntax
 
-SYMBOL: userenvs
+SYMBOL: special-objects
 
-SYNTAX: RESET H{ } clone userenvs set-global ;
+SYNTAX: RESET H{ } clone special-objects set-global ;
 
-SYNTAX: USERENV:
+SYNTAX: SPECIAL-OBJECT:
     CREATE-WORD scan-word
-    [ swap userenvs get set-at ]
+    [ swap special-objects get set-at ]
     [ drop define-symbol ]
     2bi ;

basis/calendar/calendar.factor

@@ -554,7 +554,8 @@ M: integer end-of-year 12 31 <date> ;
 : unix-time>timestamp ( seconds -- timestamp )
     seconds unix-1970 time+ ;
 
-M: duration sleep duration>nanoseconds nano-count + sleep-until ;
+M: duration sleep
+    duration>nanoseconds >integer nano-count + sleep-until ;
 
 {
     { [ os unix? ] [ "calendar.unix" ] }

basis/calendar/format/format.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.order math.parser math.functions kernel
 sequences io accessors arrays io.streams.string splitting
@@ -70,7 +70,7 @@ M: array month. ( pair -- )
     [
         [ 1 + day. ] keep
         1 + + 7 mod zero? [ nl ] [ bl ] if
-    ] with each nl ;
+    ] with each-integer nl ;
 
 M: timestamp month. ( timestamp -- )
     [ year>> ] [ month>> ] bi 2array month. ;
@@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
 GENERIC: year. ( obj -- )
 
 M: integer year. ( n -- )
-    12 [ 1 + 2array month. nl ] with each ;
+    12 [ 1 + 2array month. nl ] with each-integer ;
 
 M: timestamp year. ( timestamp -- )
     year>> year. ;

basis/checksums/sha/sha.factor

@@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
         M cloned-H sha2 T1-256
         cloned-H T2-256
         cloned-H update-H
-    ] each
+    ] each-integer
     sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
 
 M: sha2-short checksum-block
@@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
         b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
         a H nth-unsafe b H set-nth-unsafe
         a H set-nth-unsafe
-    ] each
+    ] each-integer
     state [ H [ w+ ] 2map ] change-H drop ; inline
 
 M:: sha1-state checksum-block ( bytes state -- )

basis/classes/struct/bit-accessors/bit-accessors-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
+USING: classes.struct.bit-accessors tools.test effects kernel
+sequences random stack-checker ;
 IN: classes.struct.bit-accessors.test
 
 [ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test

basis/cocoa/application/application.factor

@@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ;
 M: objc-error summary ( error -- )
     drop "Objective C exception" ;
 
-[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook
+[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
 
 : running.app? ( -- ? )
     #! Test if we're running a .app.

basis/cocoa/messages/messages.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
 classes.struct continuations combinators compiler compiler.alien
@@ -202,7 +202,7 @@ ERROR: no-objc-type name ;
     (free) ;
 
 : method-arg-types ( method -- args )
-    dup method_getNumberOfArguments
+    dup method_getNumberOfArguments iota
     [ method-arg-type ] with map ;
 
 : method-return-type ( method -- ctype )

basis/columns/columns-tests.factor

@@ -7,3 +7,5 @@ IN: columns.tests
 [ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
 [ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
 [ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
+
+[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test

basis/columns/columns.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences kernel accessors ;
 IN: columns
@@ -15,4 +15,4 @@ M: column length seq>> length ;
 INSTANCE: column virtual-sequence
 
 : <flipped> ( seq -- seq' )
-    dup empty? [ dup first length [ <column> ] with map ] unless ;
+    dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;

basis/combinators/smart/smart.factor

@@ -5,49 +5,49 @@ stack-checker math sequences ;
 IN: combinators.smart
 
 MACRO: drop-outputs ( quot -- quot' )
-    dup infer out>> '[ @ _ ndrop ] ;
+    dup outputs '[ @ _ ndrop ] ;
 
 MACRO: keep-inputs ( quot -- quot' )
-    dup infer in>> '[ _ _ nkeep ] ;
+    dup inputs '[ _ _ nkeep ] ;
 
 MACRO: output>sequence ( quot exemplar -- newquot )
-    [ dup infer out>> ] dip
+    [ dup outputs ] dip
     '[ @ _ _ nsequence ] ;
 
 MACRO: output>array ( quot -- newquot )
     '[ _ { } output>sequence ] ;
 
 MACRO: input<sequence ( quot -- newquot )
-    [ infer in>> ] keep
+    [ inputs ] keep
     '[ _ firstn @ ] ;
 
 MACRO: input<sequence-unsafe ( quot -- newquot )
-    [ infer in>> ] keep
+    [ inputs ] keep
     '[ _ firstn-unsafe @ ] ;
 
 MACRO: reduce-outputs ( quot operation -- newquot )
-    [ dup infer out>> 1 [-] ] dip n*quot compose ;
+    [ dup outputs 1 [-] ] dip n*quot compose ;
 
 MACRO: sum-outputs ( quot -- n )
     '[ _ [ + ] reduce-outputs ] ;
 
 MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
-    [ dup infer out>> ] 2dip
+    [ dup outputs ] 2dip
     [ swap '[ _ _ napply ] ]
     [ [ 1 [-] ] dip n*quot ] bi-curry* bi
     '[ @ @ @ ] ;
 
 MACRO: append-outputs-as ( quot exemplar -- newquot )
-    [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
+    [ dup outputs ] dip '[ @ _ _ nappend-as ] ;
 
 MACRO: append-outputs ( quot -- seq )
     '[ _ { } append-outputs-as ] ;
 
 MACRO: preserving ( quot -- )
-    [ infer in>> length ] keep '[ _ ndup @ ] ;
+    [ inputs ] keep '[ _ ndup @ ] ;
 
 MACRO: nullary ( quot -- quot' )
-    dup infer out>> length '[ @ _ ndrop ] ;
+    dup outputs '[ @ _ ndrop ] ;
 
 MACRO: smart-if ( pred true false -- )
     '[ _ preserving _ _ if ] ; inline

basis/command-line/command-line.factor

@@ -8,7 +8,8 @@ IN: command-line
 SYMBOL: script
 SYMBOL: command-line
 
-: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
+: (command-line) ( -- args )
+    10 special-object sift [ alien>native-string ] map ;
 
 : rc-path ( name -- path )
     os windows? [ "." prepend ] unless

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
 combinators make classes words cpu.architecture layouts
@@ -17,6 +17,7 @@ GENERIC: compute-stack-frame* ( insn -- )
 UNION: stack-frame-insn
     ##alien-invoke
     ##alien-indirect
+    ##alien-assembly
     ##alien-callback ;
 
 M: stack-frame-insn compute-stack-frame*

basis/compiler/cfg/builder/builder.factor

@@ -236,6 +236,9 @@ M: #alien-invoke emit-node
 M: #alien-indirect emit-node
     [ ##alien-indirect ] emit-alien-node ;
 
+M: #alien-assembly emit-node
+    [ ##alien-assembly ] emit-alien-node ;
+
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [

basis/compiler/cfg/instructions/instructions.factor

@@ -671,6 +671,9 @@ literal: params stack-frame ;
 INSN: ##alien-indirect
 literal: params stack-frame ;
 
+INSN: ##alien-assembly
+literal: params stack-frame ;
+
 INSN: ##alien-callback
 literal: params stack-frame ;
 

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
 make fry sequences parser accessors effects namespaces
@@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ;
     "pure-insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
-    boa-effect in>> but-last f <effect> ;
+    boa-effect in>> but-last { } <effect> ;
 
 : define-insn-tuple ( class superclass specs -- )
     [ name>> ] map "insn#" suffix define-tuple-class ;
 
 : define-insn-ctor ( class specs -- )
     [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
-    [ name>> ] map f <effect> define-declared ;
+    [ name>> ] map { } <effect> define-declared ;
 
 : define-insn ( class superclass specs -- )
     parse-insn-slot-specs {

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
@@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot
     [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
 
 :: store-initial-element ( len reg elt class -- )
-    len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
+    len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
 
 : expand-<array>? ( obj -- ? )
     dup integer? [ 0 8 between? ] [ drop f ] if ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -30,7 +30,7 @@ IN: compiler.cfg.intrinsics
 
 {
     { kernel.private:tag [ drop emit-tag ] }
-    { kernel.private:getenv [ emit-getenv ] }
+    { kernel.private:special-object [ emit-special-object ] }
     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -9,8 +9,8 @@ IN: compiler.cfg.intrinsics.misc
 : emit-tag ( -- )
     ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
-: emit-getenv ( node -- )
+: emit-special-object ( node -- )
-    "userenv" ^^vm-field-ptr
+    "special-objects" ^^vm-field-ptr
     swap node-input-infos first literal>>
     [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
     ds-push ;

basis/compiler/cfg/intrinsics/simd/backend/backend.factor

@@ -110,7 +110,7 @@ MACRO: vvvv-vector-op ( trials -- )
     blub ;
 
 MACRO: can-has-case ( cases -- )
-    dup first second infer in>> length 1 +
+    dup first second inputs 1 +
     '[ _ ndrop f ] suffix '[ _ case ] ;
 
 GENERIC# >can-has-trial 1 ( obj #pick -- quot )
@@ -118,7 +118,7 @@ GENERIC# >can-has-trial 1 ( obj #pick -- quot )
 M: callable >can-has-trial
     drop '[ _ can-has? ] ;
 M: pair >can-has-trial
-    swap first2 dup infer in>> length
+    swap first2 dup inputs
     '[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ; 
 
 MACRO: can-has-vector-op ( trials #pick #dup -- )

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit
 compiler.cfg.instructions compiler.cfg.registers
@@ -14,6 +14,7 @@ IN: compiler.cfg.save-contexts
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]
             [ ##alien-indirect? ]
+            [ ##alien-assembly? ]
         } 1||
     ] any? ;
 

basis/compiler/cfg/stacks/stacks.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math sequences kernel namespaces accessors biassocs compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
@@ -33,7 +33,7 @@ IN: compiler.cfg.stacks
 : ds-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
+    [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
 
 : ds-store ( vregs -- )
     [

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences byte-arrays namespaces accessors classes math
 math.order fry arrays combinators compiler.cfg.registers
@@ -55,7 +55,7 @@ M: insn visit-insn drop ;
     2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
 
 : (uninitialized-locs) ( seq quot -- seq' )
-    [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+    [ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
 
 PRIVATE>
 

basis/compiler/codegen/codegen.factor

@@ -380,7 +380,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
     [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
 
 : prepare-unbox-parameters ( parameters -- offsets types indices )
-    [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
+    [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
 
 : unbox-parameters ( offset node -- )
     parameters>> swap
@@ -436,6 +436,16 @@ M: ##alien-invoke generate-insn
     dup %cleanup
     box-return* ;
 
+M: ##alien-assembly generate-insn
+    params>>
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Generate assembly
+    dup quot>> call( -- )
+    ! Box return value
+    box-return* ;
+
 ! ##alien-indirect
 M: ##alien-indirect generate-insn
     params>>
@@ -464,7 +474,7 @@ M: ##alien-indirect generate-insn
 
 TUPLE: callback-context ;
 
-: current-callback ( -- id ) 2 getenv ;
+: current-callback ( -- id ) 2 special-object ;
 
 : wait-to-return ( token -- )
     dup current-callback eq? [
@@ -475,7 +485,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    [ 2 setenv call ] keep
+    [ 2 set-special-object call ] keep
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )

basis/compiler/codegen/fixup/fixup.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
 system combinators math.bitwise math.order generalizations
-accessors growable fry compiler.constants ;
+accessors growable fry compiler.constants memoize ;
 IN: compiler.codegen.fixup
 
 ! Owner
@@ -52,8 +52,11 @@ SYMBOL: relocation-table
 : rel-fixup ( class type -- )
     swap compiled-offset add-relocation-entry ;
 
+! Caching common symbol names reduces image size a bit
+MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
+
 : add-dlsym-parameters ( symbol dll -- )
-    [ string>symbol add-parameter ] [ add-parameter ] bi* ;
+    [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
 
 : rel-dlsym ( name dll class -- )
     [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;

basis/compiler/constants/constants.factor

@@ -25,6 +25,13 @@ CONSTANT: deck-bits 18
 : word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
 : array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
+: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
+: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
+: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
+: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
+: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
+: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
+: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell 0

basis/compiler/tests/alien.factor

@@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
     { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
     alien-invoke gc 3 ;
 
-[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
 
 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
     float
@@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
     { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
     alien-invoke ;
 
-[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
+[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
 
 FUNCTION: longlong ffi_test_21 long x long y ;
 
@@ -316,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
 
-[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
+[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
 
 [ t ] [ callback-1 alien? ] unit-test
 
@@ -377,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 [ f ] [ namespace global eq? ] unit-test
 
 : callback-8 ( -- callback )
-    void { } "cdecl" [
+    void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
-        [ continue ] callcc0
-    ] alien-callback ;
 
 [ ] [ callback-8 callback_test_1 ] unit-test
 
@@ -591,3 +589,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
 FUNCTION: void this_does_not_exist ( ) ;
 
 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
+
+! More alien-assembly tests are in cpu.* vocabs
+: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
+
+[ ] [ assembly-test-1 ] unit-test

basis/compiler/tests/codegen.factor

@@ -116,7 +116,7 @@ unit-test
     1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 
 [ t ] [
-    10000000 [ drop try-breaking-dispatch-2 ] all?
+    10000000 [ drop try-breaking-dispatch-2 ] all-integers?
 ] unit-test
 
 ! Regression
@@ -314,7 +314,7 @@ cell 4 = [
 
 ! Bug with ##return node construction
 : return-recursive-bug ( nodes -- ? )
-    { fixnum } declare [
+    { fixnum } declare iota [
         dup 3 bitand 1 = [ drop t ] [
             dup 3 bitand 2 = [
                 return-recursive-bug

basis/compiler/tests/float.factor

@@ -1,5 +1,5 @@
 USING: compiler.units compiler kernel kernel.private memory math
-math.private tools.test math.floats.private ;
+math.private tools.test math.floats.private math.order fry ;
 IN: compiler.tests.float
 
 [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
@@ -84,11 +84,6 @@ IN: compiler.tests.float
 
 [ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
 
-[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
-[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
-[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
-[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
-
 [ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
 [ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
 [ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
@@ -100,3 +95,23 @@ IN: compiler.tests.float
 [ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 [ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
 [ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! Ensure that float-min and min, and float-max and max, have
+! consistent behavior with respect to NaNs
+
+: two-floats ( a b -- a b ) { float float } declare ; inline
+
+[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
+[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test
+[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
+[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
+
+: check-compiled-binary-op ( a b word -- )
+    [ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
+    [ '[ _ execute ] ]
+    bi 2bi fp-bitwise= ; inline
+
+[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
+[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
+[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
+[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test

basis/compiler/tests/intrinsics.factor

@@ -54,8 +54,8 @@ IN: compiler.tests.intrinsics
 [ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
 [ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
 
-[ ] [ [ 0 getenv ] compile-call drop ] unit-test
+[ ] [ [ 0 special-object ] compile-call drop ] unit-test
-[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
+[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
 
 [ ] [ 1 [ drop ] compile-call ] unit-test
 [ ] [ [ 1 drop ] compile-call ] unit-test
@@ -337,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ;
 
 [ ] [
     10000 [
-        5 random [ drop 32 random-bits ] map product >bignum
+        5 random iota [ drop 32 random-bits ] map product >bignum
         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
         [ drop ] [ "Oops" throw ] if
     ] times

basis/compiler/tests/optimizer.factor

@@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions generic.single shuffle ;
+compiler definitions generic.single shuffle math.order ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
@@ -90,7 +90,7 @@ TUPLE: pred-test ;
 : double-label-2 ( a -- b )
     dup array? [ ] [ ] if 0 t double-label-1 ;
 
-[ 0 ] [ 10 double-label-2 ] unit-test
+[ 0 ] [ 10 iota double-label-2 ] unit-test
 
 ! regression
 GENERIC: void-generic ( obj -- * )
@@ -208,7 +208,7 @@ USE: binary-search.private
     ] if ; inline recursive
 
 [ 10 ] [
-    10 20 >vector <flat-slice>
+    10 20 iota <flat-slice>
     [ [ - ] swap old-binsearch ] compile-call 2nip
 ] unit-test
 
@@ -349,7 +349,7 @@ TUPLE: some-tuple x ;
 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
 
-[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
 
 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
 
@@ -445,5 +445,17 @@ M: object bad-dispatch-position-test* ;
 
 [ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
 
-! Not sure if I want to fix this...
+TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
-! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
+
+: grid-mesh-test-case ( -- vertices )
+    1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa
+    1 f <array>
+    [
+        [ drop length>> >fixnum 2 min ] 2keep
+        [
+            [ step>> 1 * ] dip
+            0 swap set-nth-unsafe
+        ] 2curry times
+    ] keep ;
+
+[ { 0.5 } ] [ grid-mesh-test-case ] unit-test

basis/compiler/tree/checker/checker.factor

@@ -185,9 +185,7 @@ M: #recursive check-stack-flow*
 
 M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
-M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
-
-M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
 M: #alien-callback check-stack-flow* drop ;
 

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

@@ -339,28 +339,23 @@ cell-bits 32 = [
 ] unit-test
 
 [ t ] [
-    [ { fixnum } declare length [ drop ] each-integer ]
+    [ { fixnum } declare iota [ drop ] each ]
     { < <-integer-fixnum +-integer-fixnum + } inlined?
 ] unit-test
 
 [ t ] [
-    [ { fixnum } declare [ drop ] each ]
+    [ { fixnum } declare iota 0 [ + ] reduce ]
-    { < <-integer-fixnum +-integer-fixnum + } inlined?
-] unit-test
-
-[ t ] [
-    [ { fixnum } declare 0 [ + ] reduce ]
     { < <-integer-fixnum nth-unsafe } inlined?
 ] unit-test
 
 [ f ] [
-    [ { fixnum } declare 0 [ + ] reduce ]
+    [ { fixnum } declare iota 0 [ + ] reduce ]
     \ +-integer-fixnum inlined?
 ] unit-test
 
 [ f ] [
     [
-        { integer } declare [ ] map
+        { integer } declare iota [ ] map
     ] \ >fixnum inlined?
 ] unit-test
 
@@ -403,7 +398,7 @@ cell-bits 32 = [
 
 [ t ] [
     [
-        { integer } declare [ 0 >= ] map
+        { integer } declare iota [ 0 >= ] map
     ] { >= fixnum>= } inlined?
 ] unit-test
 

basis/compiler/tree/dead-code/branches/branches.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences namespaces kernel accessors assocs sets fry
 arrays combinators columns stack-checker.backend
@@ -36,7 +36,7 @@ M: #branch remove-dead-code*
 
 : drop-indexed-values ( values indices -- node )
     [ drop filter-live ] [ swap nths ] 2bi
-    [ make-values ] keep
+    [ length make-values ] keep
     [ drop ] [ zip ] 2bi
     #data-shuffle ;
 

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs sequences kernel locals fry
 combinators stack-checker.backend
@@ -24,7 +24,7 @@ M: #call-recursive compute-live-values*
 
 :: drop-dead-inputs ( inputs outputs -- #shuffle )
     inputs filter-live
-    outputs inputs filter-corresponding make-values
+    outputs inputs filter-corresponding length make-values
     outputs
     inputs
     drop-values ;
@@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code*
     2bi ;
 
 :: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
-    inputs outputs filter-corresponding make-values :> new-live-outputs
+    inputs outputs filter-corresponding length make-values :> new-live-outputs
     outputs filter-live :> live-outputs
     new-live-outputs
     live-outputs

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
 fry locals definitions classes classes.algebra generic
@@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ;
 M: #call mark-live-values*
     dup flushable-call? [ drop ] [ look-at-inputs ] if ;
 
-M: #alien-invoke mark-live-values* look-at-inputs ;
+M: #alien-node mark-live-values* look-at-inputs ;
-
-M: #alien-indirect mark-live-values* look-at-inputs ;
 
 M: #return mark-live-values* look-at-inputs ;
 
@@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ;
 M: #shuffle compute-live-values*
     mapping>> at look-at-value ;
 
-M: #alien-invoke compute-live-values* nip look-at-inputs ;
+M: #alien-node compute-live-values* nip look-at-inputs ;
-
-M: #alien-indirect compute-live-values* nip look-at-inputs ;
 
 : filter-mapping ( assoc -- assoc' )
     live-values get '[ drop _ key? ] assoc-filter ;
@@ -71,7 +67,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     filter-corresponding zip #data-shuffle ; inline
 
 :: drop-dead-values ( outputs -- #shuffle )
-    outputs make-values :> new-outputs
+    outputs length make-values :> new-outputs
     outputs filter-live :> live-outputs
     new-outputs
     live-outputs
@@ -127,8 +123,5 @@ M: #terminate remove-dead-code*
     [ filter-live ] change-in-d
     [ filter-live ] change-in-r ;
 
-M: #alien-invoke remove-dead-code*
+M: #alien-node remove-dead-code*
-    maybe-drop-dead-outputs ;
-
-M: #alien-indirect remove-dead-code*
     maybe-drop-dead-outputs ;

basis/compiler/tree/debugger/debugger.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs match fry accessors namespaces make effects
 sequences sequences.private quotations generic macros arrays
@@ -64,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ;
 M: shuffle-node pprint* effect>> effect>string text ;
  
 : (shuffle-effect) ( in out #shuffle -- effect )
-    mapping>> '[ _ at ] map <effect> ;
+    mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
 
 : shuffle-effect ( #shuffle -- effect )
     [ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
@@ -126,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
 
 M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
 
+M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
+
 M: #alien-callback node>quot params>> , \ #alien-callback , ;
 
 M: node node>quot drop ;

basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel tools.test namespaces sequences
+USING: kernel tools.test namespaces sequences math
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.recursive.tests
@@ -6,7 +6,7 @@ IN: compiler.tree.escape-analysis.recursive.tests
 H{ } clone allocations set
 <escaping-values> escaping-values set
 
-[ ] [ 8 [ introduce-value ] each ] unit-test
+[ ] [ 8 [ introduce-value ] each-integer ] unit-test
 
 [ ] [ { 1 2 } 3 record-allocation ] unit-test
 

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -86,12 +86,7 @@ M: #call escape-analysis*
 M: #return escape-analysis*
     in-d>> add-escaping-values ;
 
-M: #alien-invoke escape-analysis*
+M: #alien-node escape-analysis*
-    [ in-d>> add-escaping-values ]
-    [ out-d>> unknown-allocations ]
-    bi ;
-
-M: #alien-indirect escape-analysis*
     [ in-d>> add-escaping-values ]
     [ out-d>> unknown-allocations ]
     bi ;

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -73,7 +73,7 @@ TUPLE: declared-fixnum { x fixnum } ;
 
 [ t ] [
     [
-        { fixnum } declare 0 swap
+        { fixnum } declare iota 0 swap
         [
             drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
         ] map
@@ -94,7 +94,7 @@ TUPLE: declared-fixnum { x fixnum } ;
 
 [ t ] [
     [
-        { integer } declare [ 256 mod ] map
+        { integer } declare iota [ 256 mod ] map
     ] { mod fixnum-mod } inlined?
 ] unit-test
 

basis/compiler/tree/normalization/normalization.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math math.order accessors kernel arrays
 combinators assocs
@@ -75,10 +75,9 @@ M: #phi normalize*
     ] with-variable ;
 
 M: #recursive normalize*
-    dup label>> introductions>>
+    [ [ child>> first ] [ in-d>> ] bi >>in-d drop ]
-    [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
+    [ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ]
-    [ make-values '[ _ (normalize) ] change-child ]
+    bi ;
-    2bi ;
 
 M: #enter-recursive normalize*
     [ introduction-stack get prepend ] change-out-d

basis/compiler/tree/propagation/call-effect/call-effect.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.private effects fry
+USING: accessors arrays combinators combinators.private effects
-kernel kernel.private make sequences continuations quotations
+fry kernel kernel.private make sequences continuations
-words math stack-checker combinators.short-circuit
+quotations words math stack-checker combinators.short-circuit
 stack-checker.transforms compiler.tree.propagation.info
 compiler.tree.propagation.inlining compiler.units ;
 IN: compiler.tree.propagation.call-effect
@@ -43,7 +43,7 @@ M: +unknown+ curry-effect ;
 M: effect curry-effect
     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
-    effect boa ;
+    [ [ "x" <array> ] bi@ ] dip effect boa ;
 
 M: curry cached-effect
     quot>> cached-effect curry-effect ;

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

@@ -4,13 +4,6 @@ IN: compiler.tree.propagation.info.tests
 
 [ f ] [ 0.0 -0.0 eql? ] unit-test
 
-[ t ] [
-    number <class-info>
-    sequence <class-info>
-    value-info-intersect
-    class>> integer class=
-] unit-test
-
 [ t t ] [
     0 10 [a,b] <interval-info>
     5 20 [a,b] <interval-info>

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel effects accessors math math.private
 math.integers.private math.floats.private math.partial-dispatch
@@ -23,11 +23,10 @@ IN: compiler.tree.propagation.known-words
 { + - * / }
 [ { number number } "input-classes" set-word-prop ] each
 
-{ /f < > <= >= u< u> u<= u>= }
+{ /f /i mod < > <= >= u< u> u<= u>= }
 [ { real real } "input-classes" set-word-prop ] each
 
-{ /i mod /mod }
+\ /mod { rational rational } "input-classes" set-word-prop
-[ { rational rational } "input-classes" set-word-prop ] each
 
 { bitand bitor bitxor bitnot shift }
 [ { integer integer } "input-classes" set-word-prop ] each

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

@@ -1,14 +1,13 @@
 USING: kernel compiler.tree.builder compiler.tree
 compiler.tree.propagation compiler.tree.recursive
-compiler.tree.normalization tools.test math math.order
+compiler.tree.normalization tools.test math math.order accessors
-accessors sequences arrays kernel.private vectors
+sequences arrays kernel.private vectors alien.accessors
-alien.accessors alien.c-types sequences.private
+alien.c-types sequences.private byte-arrays classes.algebra
-byte-arrays classes.algebra classes.tuple.private
+classes.tuple.private math.functions math.private strings
-math.functions math.private strings layouts
+layouts compiler.tree.propagation.info compiler.tree.def-use
-compiler.tree.propagation.info compiler.tree.def-use
+compiler.tree.debugger compiler.tree.checker slots.private words
-compiler.tree.debugger compiler.tree.checker
+hashtables classes assocs locals specialized-arrays system
-slots.private words hashtables classes assocs locals
+sorting math.libm math.floats.private math.integers.private
-specialized-arrays system sorting math.libm
 math.intervals quotations effects alien alien.data ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
@@ -91,6 +90,8 @@ IN: compiler.tree.propagation.tests
 
 [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
 
+[ V{ integer float } ] [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test
+
 [ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
 
 [ V{ fixnum } ] [
@@ -405,14 +406,6 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
-[ V{ 27 } ] [
-    [
-        dup number? over sequence? and [
-            dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
-        ] [ "B" throw ] if
-    ] final-literals
-] unit-test
-
 [ V{ string string } ] [
     [
         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
@@ -680,7 +673,7 @@ M: array iterate first t ; inline
 ] unit-test
 
 [ V{ fixnum } ] [
-    [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
+    [ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes
 ] unit-test
 
 [ V{ f } ] [
@@ -942,3 +935,14 @@ M: tuple-with-read-only-slot clone
 ! Could be bignum not integer but who cares
 [ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
 
+[ t ] [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test
+[ f ] [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test
+
+[ t ] [ [ { float float } declare min ] { min } inlined? ] unit-test
+[ f ] [ [ { float float } declare min ] { float-min } inlined? ] unit-test
+
+[ t ] [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test
+[ f ] [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test
+
+[ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test
+[ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -80,7 +80,7 @@ M: #declare propagate-before
 : (fold-call) ( #call word -- info )
     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
     '[ _ _ with-datastack [ <literal-info> ] map nip ]
-    [ drop [ object-info ] replicate ]
+    [ drop length [ object-info ] replicate ]
     recover ;
 
 : fold-call ( #call word -- )
@@ -153,8 +153,6 @@ M: #call propagate-after
     [ out-d>> ] [ params>> return>> ] bi
     [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 
-M: #alien-invoke propagate-before propagate-alien-invoke ;
+M: #alien-node propagate-before propagate-alien-invoke ;
-
-M: #alien-indirect propagate-before propagate-alien-invoke ;
 
 M: #return annotate-node dup in-d>> (annotate-node) ;

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel sequences words fry generic accessors
 classes.tuple classes classes.algebra definitions
@@ -132,26 +132,6 @@ IN: compiler.tree.propagation.transforms
     ] "custom-inlining" set-word-prop
 ] each
 
-! Integrate this with generic arithmetic optimization instead?
-: both-inputs? ( #call class -- ? )
-    [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
-
-\ min [
-    {
-        { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
-        { [ dup float both-inputs? ] [ [ float-min ] ] }
-        [ f ]
-    } cond nip
-] "custom-inlining" set-word-prop
-
-\ max [
-    {
-        { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
-        { [ dup float both-inputs? ] [ [ float-max ] ] }
-        [ f ]
-    } cond nip
-] "custom-inlining" set-word-prop
-
 ! Generate more efficient code for common idiom
 \ clone [
     in-d>> first value-info literal>> {
@@ -209,7 +189,7 @@ ERROR: bad-partial-eval quot word ;
 \ index [
     dup sequence? [
         dup length 4 >= [
-            dup length zip >hashtable '[ _ at ]
+            dup length iota zip >hashtable '[ _ at ]
         ] [ drop f ] if
     ] [ drop f ] if
 ] 1 define-partial-eval
@@ -248,7 +228,7 @@ CONSTANT: lookup-table-at-max 256
     } 1&& ;
 
 : lookup-table-seq ( assoc -- table )
-    [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
+    [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ;
 
 : lookup-table-quot ( seq -- newquot )
     lookup-table-seq

basis/compiler/tree/tree.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals classes
@@ -149,7 +149,12 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ;
 : #alien-indirect ( params -- node )
     \ #alien-indirect new-alien-node ;
 
-TUPLE: #alien-callback < #alien-node ;
+TUPLE: #alien-assembly < #alien-node in-d out-d ;
+
+: #alien-assembly ( params -- node )
+    \ #alien-assembly new-alien-node ;
+
+TUPLE: #alien-callback < node params ;
 
 : #alien-callback ( params -- node )
     \ #alien-callback new
@@ -187,4 +192,5 @@ M: vector #recursive, #recursive node, ;
 M: vector #copy, #copy node, ;
 M: vector #alien-invoke, #alien-invoke node, ;
 M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-assembly, #alien-assembly node, ;
 M: vector #alien-callback, #alien-callback node, ;

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -164,9 +164,7 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 
-M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ;
-
-M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #alien-callback unbox-tuples* ;
 

basis/compression/inflate/inflate.factor

@@ -36,7 +36,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
     5 bitstream bs:read 1 +
     4 bitstream bs:read 4 + clen-shuffle swap head 
 
-    dup length iota [ 3 bitstream bs:read ] replicate
+    dup length [ 3 bitstream bs:read ] replicate
     get-table
     bitstream swap <huffman-decoder>
     [ 2dup + ] dip swap :> k!
@@ -64,13 +64,13 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
 
 MEMO: static-huffman-tables ( -- obj )
     [
-        0 143 [a,b] [ 8 ] replicate
+        0 143 [a,b] length [ 8 ] replicate
-        144 255 [a,b] [ 9 ] replicate append
+        144 255 [a,b] length [ 9 ] replicate append
-        256 279 [a,b] [ 7 ] replicate append
+        256 279 [a,b] length [ 7 ] replicate append
-        280 287 [a,b] [ 8 ] replicate append
+        280 287 [a,b] length [ 8 ] replicate append
     ] append-outputs
-    0 31 [a,b] [ 5 ] replicate 2array
+    0 31 [a,b] length [ 5 ] replicate 2array
-    [ [ length>> [0,b) ] [ ] bi get-table ] map ;
+    [ [ length>> iota ] [ ] bi get-table ] map ;
 
 CONSTANT: length-table
     {

basis/compression/zlib/zlib-tests.factor

@@ -1,9 +1,12 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test compression.zlib classes ;
+USING: accessors kernel tools.test compression.zlib classes ;
+QUALIFIED-WITH: compression.zlib.ffi ffi
 IN: compression.zlib.tests
 
 : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
 
 [ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
 [ t ] [ compress-me compress compressed instance? ] unit-test
+
+[ ffi:Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with

basis/compression/zlib/zlib.factor

@@ -19,7 +19,9 @@ ERROR: zlib-failed n string ;
     dup compression.zlib.ffi:Z_ERRNO = [
         drop errno "native libc error"
     ] [
-        dup {
+        dup
+        neg ! zlib error codes are negative
+        {
             "no error" "libc_error"
             "stream error" "data error"
             "memory error" "buffer error" "zlib version error"

basis/concurrency/combinators/combinators-tests.factor

@@ -17,12 +17,12 @@ IN: concurrency.combinators.tests
 [ error>> "Even" = ] must-fail-with
 
 [ V{ 0 3 6 9 } ]
-[ 10 [ 3 mod zero? ] parallel-filter ] unit-test
+[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test
 
 [ 10 ]
 [
     V{ } clone
-    10 over [ push ] curry parallel-each
+    10 iota over [ push ] curry parallel-each
     length
 ] unit-test
 
@@ -41,7 +41,7 @@ IN: concurrency.combinators.tests
 [ 20 ]
 [
     V{ } clone
-    10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
+    10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each
     length
 ] unit-test
 

basis/cpu/architecture/architecture.factor

@@ -550,7 +550,7 @@ HOOK: %save-param-reg cpu ( stack reg rep -- )
 
 HOOK: %load-param-reg cpu ( stack reg rep -- )
 
-HOOK: %load-context cpu ( temp1 temp2 -- )
+HOOK: %restore-context cpu ( temp1 temp2 -- )
 
 HOOK: %save-context cpu ( temp1 temp2 -- )
 

basis/cpu/ppc/bootstrap.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.codegen.fixup compiler.units
-compiler.constants math math.private layouts words vocabs
+compiler.constants math math.private math.ranges layouts words vocabs
-slots.private locals locals.backend generic.single.private fry ;
+slots.private locals locals.backend generic.single.private fry
+sequences ;
 FROM: cpu.ppc.assembler => B ;
 IN: bootstrap.ppc
 
@@ -13,28 +14,88 @@ big-endian on
 CONSTANT: ds-reg 13
 CONSTANT: rs-reg 14
 CONSTANT: vm-reg 15
+CONSTANT: ctx-reg 16
 
-: factor-area-size ( -- n ) 4 bootstrap-cells ;
+: factor-area-size ( -- n ) 16 ;
 
 : stack-frame ( -- n )
-    factor-area-size c-area-size + 4 bootstrap-cells align ;
+    reserved-size
+    factor-area-size +
+    16 align ;
 
-: next-save ( -- n ) stack-frame bootstrap-cell - ;
+: next-save ( -- n ) stack-frame 4 - ;
-: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
+: xt-save ( -- n ) stack-frame 8 - ;
+
+: param-size ( -- n ) 32 ;
+
+: save-at ( m -- n ) reserved-size + param-size + ;
+
+: save-int ( register offset -- ) [ 1 ] dip save-at STW ;
+: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;
+
+: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;
+: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;
+
+: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;
+: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;
+
+: nv-int-regs ( -- seq ) 13 31 [a,b] ;
+: nv-fp-regs ( -- seq ) 14 31 [a,b] ;
+: nv-vec-regs ( -- seq ) 20 31 [a,b] ;
+
+: saved-int-regs-size ( -- n ) 96 ;
+: saved-fp-regs-size ( -- n ) 144 ;
+: saved-vec-regs-size ( -- n ) 208 ;
+
+: callback-frame-size ( -- n )
+    reserved-size
+    param-size +
+    saved-int-regs-size +
+    saved-fp-regs-size +
+    saved-vec-regs-size +
+    16 align ;
+
+[
+    0 MFLR
+    1 1 callback-frame-size neg STWU
+    0 1 callback-frame-size lr-save + STW
+
+    nv-int-regs [ 4 * save-int ] each-index
+    nv-fp-regs [ 8 * 80 + save-fp ] each-index
+    nv-vec-regs [ 16 * 224 + save-vec ] each-index
+
+    0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
+
+    0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel
+    2 MTLR
+    BLRL
+
+    nv-vec-regs [ 16 * 224 + restore-vec ] each-index
+    nv-fp-regs [ 8 * 80 + restore-fp ] each-index
+    nv-int-regs [ 4 * restore-int ] each-index
+
+    0 1 callback-frame-size lr-save + LWZ
+    1 1 0 LWZ
+    0 MTLR
+    BLR
+] callback-stub jit-define
 
 : jit-conditional* ( test-quot false-quot -- )
-    [ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline
+    [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline
+
+: jit-load-context ( -- )
+    ctx-reg vm-reg vm-context-offset LWZ ;
 
 : jit-save-context ( -- )
-    4 vm-reg 0 LWZ
+    jit-load-context
-    1 4 0 STW
+    1 ctx-reg context-callstack-top-offset STW
-    ds-reg 4 8 STW
+    ds-reg ctx-reg context-datastack-offset STW
-    rs-reg 4 12 STW ;
+    rs-reg ctx-reg context-retainstack-offset STW ;
 
 : jit-restore-context ( -- )
-    4 vm-reg 0 LWZ
+    jit-load-context
-    ds-reg 4 8 LWZ
+    ds-reg ctx-reg context-datastack-offset LWZ
-    rs-reg 4 12 LWZ ;
+    rs-reg ctx-reg context-retainstack-offset LWZ ;
 
 [
     0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
@@ -48,12 +109,12 @@ CONSTANT: vm-reg 15
 ] jit-profiling jit-define
 
 [
-    0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
+    0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
     0 MFLR
     1 1 stack-frame SUBI
-    3 1 xt-save STW
+    2 1 xt-save STW
-    stack-frame 3 LI
+    stack-frame 2 LI
-    3 1 next-save STW
+    2 1 next-save STW
     0 1 lr-save stack-frame + STW
 ] jit-prolog jit-define
 
@@ -181,7 +242,7 @@ CONSTANT: vm-reg 15
     load-tag
     0 4 tuple type-number tag-fixnum CMPI
     [ BNE ]
-    [ 4 3 tuple type-number neg bootstrap-cell + LWZ ]
+    [ 4 3 tuple type-number neg 4 + LWZ ]
     jit-conditional*
 ] pic-tuple jit-define
 
@@ -215,12 +276,12 @@ CONSTANT: vm-reg 15
 [ jit-load-return-address jit-inline-cache-miss ]
 [ 3 MTLR BLRL ]
 [ 3 MTCTR BCTR ]
-\ inline-cache-miss define-sub-primitive*
+\ inline-cache-miss define-combinator-primitive
 
 [ jit-inline-cache-miss ]
 [ 3 MTLR BLRL ]
 [ 3 MTCTR BCTR ]
-\ inline-cache-miss-tail define-sub-primitive*
+\ inline-cache-miss-tail define-combinator-primitive
 
 ! ! ! Megamorphic caches
 
@@ -230,7 +291,7 @@ CONSTANT: vm-reg 15
     ! key = hashcode(class)
     5 4 1 SRAWI
     ! key &= cache.length - 1
-    5 5 mega-cache-size get 1 - bootstrap-cell * ANDI
+    5 5 mega-cache-size get 1 - 4 * ANDI
     ! cache += array-start-offset
     3 3 array-start-offset ADDI
     ! cache += key
@@ -245,7 +306,7 @@ CONSTANT: vm-reg 15
         5 4 0 LWZ
         5 5 1 ADDI
         5 4 0 STW
-        ! ... goto get(cache + bootstrap-cell)
+        ! ... goto get(cache + 4)
         3 3 4 LWZ
         3 3 word-xt-offset LWZ
         3 MTCTR
@@ -255,23 +316,16 @@ CONSTANT: vm-reg 15
     ! fall-through on miss
 ] mega-lookup jit-define
 
-[
-    0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel
-    2 MTCTR
-    BCTR
-] callback-stub jit-define
-
 ! ! ! Sub-primitives
 
 ! Quotations and words
 [
     3 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
-    4 vm-reg MR
     5 3 quot-xt-offset LWZ
 ]
 [ 5 MTLR BLRL ]
-[ 5 MTCTR BCTR ] \ (call) define-sub-primitive*
+[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -279,7 +333,7 @@ CONSTANT: vm-reg 15
     4 3 word-xt-offset LWZ
 ]
 [ 4 MTLR BLRL ]
-[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive*
+[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive
 
 [
     3 ds-reg 0 LWZ
@@ -288,6 +342,79 @@ CONSTANT: vm-reg 15
     4 MTCTR BCTR
 ] jit-execute jit-define
 
+! Special primitives
+[
+    jit-restore-context
+    ! Save ctx->callstack_bottom
+    1 ctx-reg context-callstack-bottom-offset STW
+    ! Call quotation
+    5 3 quot-xt-offset LWZ
+    5 MTLR
+    BLRL
+    jit-save-context
+] \ c-to-factor define-sub-primitive
+
+[
+    ! Unwind stack frames
+    1 4 MR
+
+    ! Load VM pointer into vm-reg, since we're entering from
+    ! C code
+    0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
+
+    ! Load ds and rs registers
+    jit-restore-context
+
+    ! We have changed the stack; load return address again
+    0 1 lr-save LWZ
+    0 MTLR
+
+    ! Call quotation
+    4 3 quot-xt-offset LWZ
+    4 MTCTR
+    BCTR
+] \ unwind-native-frames define-sub-primitive
+
+[
+    ! Load callstack object
+    6 ds-reg 0 LWZ
+    ds-reg ds-reg 4 SUBI
+    ! Get ctx->callstack_bottom
+    jit-load-context
+    3 ctx-reg context-callstack-bottom-offset LWZ
+    ! Get top of callstack object -- 'src' for memcpy
+    4 6 callstack-top-offset ADDI
+    ! Get callstack length, in bytes --- 'len' for memcpy
+    5 6 callstack-length-offset LWZ
+    5 5 tag-bits get SRAWI
+    ! Compute new stack pointer -- 'dst' for memcpy
+    3 5 3 SUBF
+    ! Install new stack pointer
+    1 3 MR
+    ! Call memcpy; arguments are now in the correct registers
+    1 1 -64 STWU
+    0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym
+    2 MTLR
+    BLRL
+    1 1 0 LWZ
+    ! Return with new callstack
+    0 1 lr-save LWZ
+    0 MTLR
+    BLR
+] \ set-callstack define-sub-primitive
+
+[
+    jit-save-context
+    4 vm-reg MR
+    0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym
+    2 MTLR
+    BLRL
+    5 3 quot-xt-offset LWZ
+]
+[ 5 MTLR BLRL ]
+[ 5 MTCTR BCTR ]
+\ lazy-jit-compile define-combinator-primitive
+
 ! Objects
 [
     3 ds-reg 0 LWZ

basis/cpu/ppc/linux/bootstrap.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser layouts system kernel sequences ;
+USING: parser system kernel sequences ;
 IN: bootstrap.ppc
 
-: c-area-size ( -- n ) 10 bootstrap-cells ;
+: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) bootstrap-cell ;
+: lr-save ( -- n ) 4 ;
 
 << "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/ppc/macosx/bootstrap.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser layouts system kernel sequences ;
+USING: parser system kernel sequences ;
 IN: bootstrap.ppc
 
-: c-area-size ( -- n ) 14 bootstrap-cells ;
+: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) 2 bootstrap-cells ;
+: lr-save ( -- n ) 8 ;
 
 << "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
 call

basis/cpu/ppc/ppc.factor

@@ -83,8 +83,8 @@ HOOK: reserved-area-size os ( -- n )
 ! The start of the stack frame contains the size of this frame
 ! as well as the currently executing XT
 : factor-area-size ( -- n ) 2 cells ; foldable
-: next-save ( n -- i ) cell - ;
+: next-save ( n -- i ) cell - ; foldable
-: xt-save ( n -- i ) 2 cells - ;
+: xt-save ( n -- i ) 2 cells - ; foldable
 
 ! Next, we have the spill area as well as the FFI parameter area.
 ! It is safe for them to overlap, since basic blocks with FFI calls
@@ -126,7 +126,7 @@ M: ppc stack-frame-size ( stack-frame -- i )
 M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
 
 M: ppc %jump ( word -- )
-    0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
+    0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
     0 B rc-relative-ppc-3 rel-word-pic-tail ;
 
 M: ppc %jump-label ( label -- ) B ;
@@ -134,7 +134,7 @@ M: ppc %return ( -- ) BLR ;
 
 M:: ppc %dispatch ( src temp -- )
     0 temp LOAD32
-    4 cells rc-absolute-ppc-2/2 rel-here
+    3 cells rc-absolute-ppc-2/2 rel-here
     temp temp src LWZX
     temp MTCTR
     BCTR ;
@@ -564,14 +564,16 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
         { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
     } case ;
 
-: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+: next-param@ ( n -- reg x )
+    2 1 stack-frame get total-size>> LWZ
+    [ 2 ] dip param@ ;
 
 : store-to-frame ( src n rep -- )
     {
         { int-rep [ [ 1 ] dip STW ] }
         { float-rep [ [ 1 ] dip STFS ] }
         { double-rep [ [ 1 ] dip STFD ] }
-        { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
+        { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
     } case ;
 
 M: ppc %spill ( src rep dst -- )
@@ -679,10 +681,15 @@ M: ppc %box-large-struct ( n c-type -- )
     ! Call the function
     "from_value_struct" f %alien-invoke ;
 
+M:: ppc %restore-context ( temp1 temp2 -- )
+    temp1 "ctx" %load-vm-field-addr
+    temp1 temp1 0 LWZ
+    temp2 1 stack-frame get total-size>> ADDI
+    temp2 temp1 "callstack-bottom" context-field-offset STW
+    ds-reg temp1 8 LWZ
+    rs-reg temp1 12 LWZ ;
+
 M:: ppc %save-context ( temp1 temp2 -- )
-    #! Save Factor stack pointers in case the C code calls a
-    #! callback which does a GC, which must reliably trace
-    #! all roots.
     temp1 "ctx" %load-vm-field-addr
     temp1 temp1 0 LWZ
     1 temp1 0 STW
@@ -693,13 +700,18 @@ M: ppc %alien-invoke ( symbol dll -- )
     [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
+    3 4 %restore-context
     3 swap %load-reference
-    4 %load-vm-addr
+    4 3 quot-xt-offset LWZ
-    "c_to_factor" f %alien-invoke ;
+    4 MTLR
+    BLRL
+    3 4 %save-context ;
 
 M: ppc %prepare-alien-indirect ( -- )
-    3 %load-vm-addr
+    3 ds-reg 0 LWZ
-    "from_alien" f %alien-invoke
+    ds-reg ds-reg 4 SUBI
+    4 %load-vm-addr
+    "pinned_alien_offset" f %alien-invoke
     16 3 MR ;
 
 M: ppc %alien-indirect ( -- )
@@ -753,9 +765,7 @@ M: ppc %box-small-struct ( c-type -- )
     3 3 0 LWZ ;
 
 M: ppc %nest-stacks ( -- )
-    ! Save current frame. See comment in vm/contexts.hpp
+    3 %load-vm-addr
-    3 1 stack-frame get total-size>> 2 cells - ADDI
-    4 %load-vm-addr
     "nest_stacks" f %alien-invoke ;
 
 M: ppc %unnest-stacks ( -- )
@@ -763,7 +773,6 @@ M: ppc %unnest-stacks ( -- )
     "unnest_stacks" f %alien-invoke ;
 
 M: ppc %unbox-small-struct ( size -- )
-    #! Alien must be in EAX.
     heap-size cell align cell /i {
         { 1 [ %unbox-struct-1 ] }
         { 2 [ %unbox-struct-2 ] }

basis/cpu/x86/32/32-tests.factor

@@ -0,0 +1,7 @@
+IN: cpu.x86.32.tests
+USING: alien alien.c-types tools.test cpu.x86.assembler
+cpu.x86.assembler.operands ;
+
+: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ;
+
+[ 3 ] [ assembly-test-1 ] unit-test

basis/cpu/x86/32/32.factor

@@ -8,7 +8,8 @@ compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture ;
+cpu.architecture vm ;
+FROM: layouts => cell ;
 IN: cpu.x86.32
 
 M: x86.32 machine-registers
@@ -23,6 +24,12 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
+M: x86.32 %mov-vm-ptr ( reg -- )
+    0 MOV 0 rc-absolute-cell rel-vm ;
+
+M: x86.32 %vm-field-ptr ( dst field -- )
+    [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+
 : local@ ( n -- op )
     stack-frame get extra-stack-space dup 16 assert= + stack@ ;
 
@@ -235,9 +242,8 @@ M: x86.32 %alien-indirect ( -- )
     EBP CALL ;
 
 M: x86.32 %alien-callback ( quot -- )
-    EAX EDX %load-context
+    EAX EDX %restore-context
     EAX swap %load-reference
-    EDX %mov-vm-ptr
     EAX quot-xt-offset [+] CALL
     EAX EDX %save-context ;
 

basis/cpu/x86/32/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler cpu.x86.assembler.operands layouts
@@ -19,6 +19,8 @@ IN: bootstrap.x86
 : safe-reg ( -- reg ) EAX ;
 : stack-reg ( -- reg ) ESP ;
 : frame-reg ( -- reg ) EBP ;
+: vm-reg ( -- reg ) ECX ;
+: ctx-reg ( -- reg ) EBP ;
 : nv-regs ( -- seq ) { ESI EDI EBX } ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
@@ -35,49 +37,122 @@ IN: bootstrap.x86
 ] jit-prolog jit-define
 
 : jit-load-vm ( -- )
-    EBP 0 MOV 0 rc-absolute-cell jit-vm ;
+    vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
+
+: jit-load-context ( -- )
+    ! VM pointer must be in vm-reg already
+    ctx-reg vm-reg vm-context-offset [+] MOV ;
 
 : jit-save-context ( -- )
-    ! VM pointer must be in EBP already
+    EDX RSP -4 [+] LEA
-    ECX EBP [] MOV
+    ctx-reg context-callstack-top-offset [+] EDX MOV
-    ! save ctx->callstack_top
+    ctx-reg context-datastack-offset [+] ds-reg MOV
-    EAX ESP -4 [+] LEA
+    ctx-reg context-retainstack-offset [+] rs-reg MOV ;
-    ECX [] EAX MOV
-    ! save ctx->datastack
-    ECX 8 [+] ds-reg MOV
-    ! save ctx->retainstack
-    ECX 12 [+] rs-reg MOV ;
 
 : jit-restore-context ( -- )
-    ! VM pointer must be in EBP already
+    ds-reg ctx-reg context-datastack-offset [+] MOV
-    ECX EBP [] MOV
+    rs-reg ctx-reg context-retainstack-offset [+] MOV ;
-    ! restore ctx->datastack
-    ds-reg ECX 8 [+] MOV
-    ! restore ctx->retainstack
-    rs-reg ECX 12 [+] MOV ;
 
 [
     jit-load-vm
-    ! save ds, rs registers
+    jit-load-context
     jit-save-context
     ! call the primitive
-    ESP [] EBP MOV
+    ESP [] vm-reg MOV
     0 CALL rc-relative rt-primitive jit-rel
     ! restore ds, rs registers
     jit-restore-context
 ] jit-primitive jit-define
 
 [
-    ! load from stack
+    ! Load quotation
+    EAX EBP 8 [+] MOV
+    ! save ctx->callstack_bottom, load ds, rs registers
+    jit-load-vm
+    jit-load-context
+    jit-restore-context
+    EDX stack-reg stack-frame-size 4 - [+] LEA
+    ctx-reg context-callstack-bottom-offset [+] EDX MOV
+    ! call the quotation
+    EAX quot-xt-offset [+] CALL
+    ! save ds, rs registers
+    jit-save-context
+] \ c-to-factor define-sub-primitive
+
+[
     EAX ds-reg [] MOV
-    ! pop stack
     ds-reg bootstrap-cell SUB
-    ! load VM pointer
-    EDX 0 MOV 0 rc-absolute-cell jit-vm
 ]
 [ EAX quot-xt-offset [+] CALL ]
 [ EAX quot-xt-offset [+] JMP ]
-\ (call) define-sub-primitive*
+\ (call) define-combinator-primitive
+
+[
+    ! Clear x87 stack, but preserve rounding mode and exception flags
+    ESP 2 SUB
+    ESP [] FNSTCW
+    FNINIT
+    ESP [] FLDCW
+    ESP 2 ADD
+
+    ! Load arguments
+    EAX ESP stack-frame-size [+] MOV
+    EDX ESP stack-frame-size 4 + [+] MOV
+
+    ! Unwind stack frames
+    ESP EDX MOV
+
+    ! Load ds and rs registers
+    jit-load-vm
+    jit-load-context
+    jit-restore-context
+
+    ! Call quotation
+    EAX quot-xt-offset [+] JMP
+] \ unwind-native-frames define-sub-primitive
+
+[
+    ! Load callstack object
+    EBX ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    ! Get ctx->callstack_bottom
+    jit-load-vm
+    jit-load-context
+    EAX ctx-reg context-callstack-bottom-offset [+] MOV
+    ! Get top of callstack object -- 'src' for memcpy
+    EBP EBX callstack-top-offset [+] LEA
+    ! Get callstack length, in bytes --- 'len' for memcpy
+    EDX EBX callstack-length-offset [+] MOV
+    EDX tag-bits get SHR
+    ! Compute new stack pointer -- 'dst' for memcpy
+    EAX EDX SUB
+    ! Install new stack pointer
+    ESP EAX MOV
+    ! Call memcpy
+    EDX PUSH
+    EBP PUSH
+    EAX PUSH
+    0 CALL "factor_memcpy" f rc-relative jit-dlsym
+    ESP 12 ADD
+    ! Return with new callstack
+    0 RET
+] \ set-callstack define-sub-primitive
+
+[
+    jit-load-vm
+    jit-load-context
+    jit-save-context
+
+    ! Store arguments
+    ESP [] EAX MOV
+    ESP 4 [+] vm-reg MOV
+
+    ! Call VM
+    0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
+]
+[ EAX quot-xt-offset [+] CALL ]
+[ EAX quot-xt-offset [+] JMP ]
+\ lazy-jit-compile define-combinator-primitive
 
 ! Inline cache miss entry points
 : jit-load-return-address ( -- )
@@ -87,8 +162,9 @@ IN: bootstrap.x86
 ! frame, and the stack. The frame setup takes this into account.
 : jit-inline-cache-miss ( -- )
     jit-load-vm
+    jit-load-context
     jit-save-context
-    ESP 4 [+] EBP MOV
+    ESP 4 [+] vm-reg MOV
     ESP [] EBX MOV
     0 CALL "inline_cache_miss" f rc-relative jit-dlsym
     jit-restore-context ;
@@ -96,28 +172,29 @@ IN: bootstrap.x86
 [ jit-load-return-address jit-inline-cache-miss ]
 [ EAX CALL ]
 [ EAX JMP ]
-\ inline-cache-miss define-sub-primitive*
+\ inline-cache-miss define-combinator-primitive
 
 [ jit-inline-cache-miss ]
 [ EAX CALL ]
 [ EAX JMP ]
-\ inline-cache-miss-tail define-sub-primitive*
+\ inline-cache-miss-tail define-combinator-primitive
 
 ! Overflowing fixnum arithmetic
 : jit-overflow ( insn func -- )
     ds-reg 4 SUB
     jit-load-vm
+    jit-load-context
     jit-save-context
     EAX ds-reg [] MOV
     EDX ds-reg 4 [+] MOV
-    ECX EAX MOV
+    EBX EAX MOV
-    [ [ ECX EDX ] dip call( dst src -- ) ] dip
+    [ [ EBX EDX ] dip call( dst src -- ) ] dip
-    ds-reg [] ECX MOV
+    ds-reg [] EBX MOV
     [ JNO ]
     [
         ESP [] EAX MOV
         ESP 4 [+] EDX MOV
-        ESP 8 [+] EBP MOV
+        ESP 8 [+] vm-reg MOV
         [ 0 CALL ] dip f rc-relative jit-dlsym
     ]
     jit-conditional ;
@@ -129,19 +206,20 @@ IN: bootstrap.x86
 [
     ds-reg 4 SUB
     jit-load-vm
+    jit-load-context
     jit-save-context
-    ECX ds-reg [] MOV
+    EBX ds-reg [] MOV
-    EAX ECX MOV
+    EAX EBX MOV
-    EBX ds-reg 4 [+] MOV
+    EBP ds-reg 4 [+] MOV
-    EBX tag-bits get SAR
+    EBP tag-bits get SAR
-    EBX IMUL
+    EBP IMUL
     ds-reg [] EAX MOV
     [ JNO ]
     [
-        ECX tag-bits get SAR
+        EBX tag-bits get SAR
-        ESP [] ECX MOV
+        ESP [] EBX MOV
-        ESP 4 [+] EBX MOV
+        ESP 4 [+] EBP MOV
-        ESP 8 [+] EBP MOV
+        ESP 8 [+] vm-reg MOV
         0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
     ]
     jit-conditional

basis/cpu/x86/64/64-tests.factor

@@ -0,0 +1,15 @@
+USING: alien alien.c-types cpu.architecture cpu.x86.64
+cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
+IN: cpu.x86.64.tests
+
+: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ;
+
+[ 3 ] [ assembly-test-1 ] unit-test
+
+: assembly-test-2 ( a b -- x )
+    int { int int } "cdecl" [
+        param-reg-0 param-reg-1 ADD
+        int-regs return-reg param-reg-0 MOV
+    ] alien-assembly ;
+
+[ 23 ] [ 17 6 assembly-test-2 ] unit-test

basis/cpu/x86/64/64.factor

@@ -7,7 +7,8 @@ compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture ;
+cpu.architecture vm ;
+FROM: layouts => cell cells ;
 IN: cpu.x86.64
 
 : param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
@@ -29,13 +30,21 @@ M: x86.64 extra-stack-space drop 0 ;
 
 M: x86.64 machine-registers
     {
-        { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+        { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } }
         { float-regs {
             XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
         } }
     } ;
 
+: vm-reg ( -- reg ) R13 ; inline
+
+M: x86.64 %mov-vm-ptr ( reg -- )
+    vm-reg MOV ;
+
+M: x86.64 %vm-field-ptr ( dst field -- )
+    [ vm-reg ] dip vm-field-offset [+] LEA ;
+
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
 M: x86.64 %prologue ( n -- )
@@ -223,9 +232,8 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    param-reg-0 param-reg-1 %load-context
+    param-reg-0 param-reg-1 %restore-context
     param-reg-0 swap %load-reference
-    param-reg-1 %mov-vm-ptr
     param-reg-0 quot-xt-offset [+] CALL
     param-reg-0 param-reg-1 %save-context ;
 

basis/cpu/x86/64/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system layouts vocabs parser compiler.constants math
@@ -15,9 +15,12 @@ IN: bootstrap.x86
 : temp1 ( -- reg ) RSI ;
 : temp2 ( -- reg ) RDX ;
 : temp3 ( -- reg ) RBX ;
+: return-reg ( -- reg ) RAX ;
 : safe-reg ( -- reg ) RAX ;
 : stack-reg ( -- reg ) RSP ;
 : frame-reg ( -- reg ) RBP ;
+: ctx-reg ( -- reg ) R12 ;
+: vm-reg ( -- reg ) R13 ;
 : ds-reg ( -- reg ) R14 ;
 : rs-reg ( -- reg ) R15 ;
 : fixnum>slot@ ( -- ) temp0 1 SAR ;
@@ -25,60 +28,114 @@ IN: bootstrap.x86
 
 [
     ! load XT
-    RDI 0 MOV rc-absolute-cell rt-this jit-rel
+    safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
     ! save stack frame size
     stack-frame-size PUSH
     ! push XT
-    RDI PUSH
+    safe-reg PUSH
     ! alignment
     RSP stack-frame-size 3 bootstrap-cells - SUB
 ] jit-prolog jit-define
 
-: jit-load-vm ( -- )
+: jit-load-context ( -- )
-    RBP 0 MOV 0 rc-absolute-cell jit-vm ;
+    ctx-reg vm-reg vm-context-offset [+] MOV ;
 
 : jit-save-context ( -- )
-    ! VM pointer must be in RBP already
+    jit-load-context
-    RCX RBP [] MOV
+    safe-reg RSP -8 [+] LEA
-    ! save ctx->callstack_top
+    ctx-reg context-callstack-top-offset [+] safe-reg MOV
-    RAX RSP -8 [+] LEA
+    ctx-reg context-datastack-offset [+] ds-reg MOV
-    RCX [] RAX MOV
+    ctx-reg context-retainstack-offset [+] rs-reg MOV ;
-    ! save ctx->datastack
-    RCX 16 [+] ds-reg MOV
-    ! save ctx->retainstack
-    RCX 24 [+] rs-reg MOV ;
 
 : jit-restore-context ( -- )
-    ! VM pointer must be in EBP already
+    jit-load-context
-    RCX RBP [] MOV
+    ds-reg ctx-reg context-datastack-offset [+] MOV
-    ! restore ctx->datastack
+    rs-reg ctx-reg context-retainstack-offset [+] MOV ;
-    ds-reg RCX 16 [+] MOV
-    ! restore ctx->retainstack
-    rs-reg RCX 24 [+] MOV ;
 
 [
-    jit-load-vm
-    ! save ds, rs registers
     jit-save-context
     ! call the primitive
-    arg1 RBP MOV
+    arg1 vm-reg MOV
     RAX 0 MOV rc-absolute-cell rt-primitive jit-rel
     RAX CALL
-    ! restore ds, rs registers
     jit-restore-context
 ] jit-primitive jit-define
 
 [
-    ! load from stack
+    jit-restore-context
+    ! save ctx->callstack_bottom
+    safe-reg stack-reg stack-frame-size 8 - [+] LEA
+    ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
+    ! call the quotation
+    arg1 quot-xt-offset [+] CALL
+    jit-save-context
+] \ c-to-factor define-sub-primitive
+
+[
     arg1 ds-reg [] MOV
-    ! pop stack
     ds-reg bootstrap-cell SUB
-    ! load VM pointer
-    arg2 0 MOV 0 rc-absolute-cell jit-vm
 ]
 [ arg1 quot-xt-offset [+] CALL ]
 [ arg1 quot-xt-offset [+] JMP ]
-\ (call) define-sub-primitive*
+\ (call) define-combinator-primitive
+
+[
+    ! Clear x87 stack, but preserve rounding mode and exception flags
+    RSP 2 SUB
+    RSP [] FNSTCW
+    FNINIT
+    RSP [] FLDCW
+
+    ! Unwind stack frames
+    RSP arg2 MOV
+
+    ! Load VM pointer into vm-reg, since we're entering from
+    ! C code
+    vm-reg 0 MOV 0 rc-absolute-cell jit-vm
+
+    ! Load ds and rs registers
+    jit-restore-context
+
+    ! Call quotation
+    arg1 quot-xt-offset [+] JMP
+] \ unwind-native-frames define-sub-primitive
+
+[
+    ! Load callstack object
+    arg4 ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    ! Get ctx->callstack_bottom
+    jit-load-context
+    arg1 ctx-reg context-callstack-bottom-offset [+] MOV
+    ! Get top of callstack object -- 'src' for memcpy
+    arg2 arg4 callstack-top-offset [+] LEA
+    ! Get callstack length, in bytes --- 'len' for memcpy
+    arg3 arg4 callstack-length-offset [+] MOV
+    arg3 tag-bits get SHR
+    ! Compute new stack pointer -- 'dst' for memcpy
+    arg1 arg3 SUB
+    ! Install new stack pointer
+    RSP arg1 MOV
+    ! Call memcpy; arguments are now in the correct registers
+    ! Create register shadow area for Win64
+    RSP 32 SUB
+    safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
+    safe-reg CALL
+    ! Tear down register shadow area
+    RSP 32 ADD
+    ! Return with new callstack
+    0 RET
+] \ set-callstack define-sub-primitive
+
+[
+    jit-save-context
+    arg2 vm-reg MOV
+    safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
+    safe-reg CALL
+]
+[ return-reg quot-xt-offset [+] CALL ]
+[ return-reg quot-xt-offset [+] JMP ]
+\ lazy-jit-compile define-combinator-primitive
 
 ! Inline cache miss entry points
 : jit-load-return-address ( -- )
@@ -87,10 +144,9 @@ IN: bootstrap.x86
 ! These are always in tail position with an existing stack
 ! frame, and the stack. The frame setup takes this into account.
 : jit-inline-cache-miss ( -- )
-    jit-load-vm
     jit-save-context
     arg1 RBX MOV
-    arg2 RBP MOV
+    arg2 vm-reg MOV
     RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
     RAX CALL
     jit-restore-context ;
@@ -98,17 +154,16 @@ IN: bootstrap.x86
 [ jit-load-return-address jit-inline-cache-miss ]
 [ RAX CALL ]
 [ RAX JMP ]
-\ inline-cache-miss define-sub-primitive*
+\ inline-cache-miss define-combinator-primitive
 
 [ jit-inline-cache-miss ]
 [ RAX CALL ]
 [ RAX JMP ]
-\ inline-cache-miss-tail define-sub-primitive*
+\ inline-cache-miss-tail define-combinator-primitive
 
 ! Overflowing fixnum arithmetic
 : jit-overflow ( insn func -- )
     ds-reg 8 SUB
-    jit-load-vm
     jit-save-context
     arg1 ds-reg [] MOV
     arg2 ds-reg 8 [+] MOV
@@ -117,7 +172,7 @@ IN: bootstrap.x86
     ds-reg [] arg3 MOV
     [ JNO ]
     [
-        arg3 RBP MOV
+        arg3 vm-reg MOV
         RAX 0 MOV f rc-absolute-cell jit-dlsym
         RAX CALL
     ]
@@ -129,7 +184,6 @@ IN: bootstrap.x86
 
 [
     ds-reg 8 SUB
-    jit-load-vm
     jit-save-context
     RCX ds-reg [] MOV
     RBX ds-reg 8 [+] MOV
@@ -142,7 +196,7 @@ IN: bootstrap.x86
         arg1 RCX MOV
         arg1 tag-bits get SAR
         arg2 RBX MOV
-        arg3 RBP MOV
+        arg3 vm-reg MOV
         RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
         RAX CALL
     ]

basis/cpu/x86/assembler/assembler.factor

@@ -375,6 +375,7 @@ PRIVATE>
 : NOP ( -- ) HEX: 90 , ;
 : PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
 
+: RDTSC ( -- ) HEX: 0f , HEX: 31 , ;
 : RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
 
 ! x87 Floating Point Unit
@@ -385,6 +386,13 @@ PRIVATE>
 : FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
 : FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 
+: FNSTCW ( operand -- ) { BIN: 111 f HEX: d9 } 1-operand ;
+: FNSTSW ( operand -- ) { BIN: 111 f HEX: dd } 1-operand ;
+: FLDCW ( operand -- ) { BIN: 101 f HEX: d9 } 1-operand ;
+
+: FNCLEX ( -- ) HEX: db , HEX: e2 , ;
+: FNINIT ( -- ) HEX: db , HEX: e3 , ;
+
 ! SSE multimedia instructions
 
 <PRIVATE

basis/cpu/x86/bootstrap.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private compiler.constants
 compiler.units cpu.x86.assembler cpu.x86.assembler.operands
@@ -30,6 +30,9 @@ big-endian off
     ! hurt on other platforms
     stack-reg 32 SUB
 
+    ! Load VM into vm-reg
+    vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
+
     ! Call into Factor code
     safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel
     safe-reg CALL
@@ -169,7 +172,7 @@ big-endian off
 ]
 [ temp0 word-xt-offset [+] CALL ]
 [ temp0 word-xt-offset [+] JMP ]
-\ (execute) define-sub-primitive*
+\ (execute) define-combinator-primitive
 
 [
     temp0 ds-reg [] MOV

basis/cpu/x86/features/features.factor

@@ -1,21 +1,78 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel memoize math math.order math.parser
+USING: accessors alien alien.c-types combinators compiler
-namespaces alien.c-types alien.syntax combinators locals init io
+compiler.codegen.fixup compiler.units cpu.architecture
-compiler compiler.units accessors ;
+cpu.x86.assembler cpu.x86.assembler.operands init io kernel
+locals math math.order math.parser memoize namespaces system ;
 IN: cpu.x86.features
 
 <PRIVATE
 
-FUNCTION: int sse_version ( ) ;
+: (sse-version) ( -- n )
+    int { } "cdecl" [
+        "sse-42" define-label
+        "sse-41" define-label
+        "ssse-3" define-label
+        "sse-3" define-label
+        "sse-2" define-label
+        "sse-1" define-label
+        "end" define-label
 
-FUNCTION: longlong read_timestamp_counter ( ) ;
+        int-regs return-reg 1 MOV
+
+        CPUID
+
+        ECX HEX: 100000 TEST
+        "sse-42" get JNE
+
+        ECX HEX: 80000 TEST
+        "sse-41" get JNE
+
+        ECX HEX: 200 TEST
+        "ssse-3" get JNE
+
+        ECX HEX: 1 TEST
+        "sse-3" get JNE
+
+        EDX HEX: 4000000 TEST
+        "sse-2" get JNE
+
+        EDX HEX: 2000000 TEST
+        "sse-1" get JNE
+
+        int-regs return-reg 0 MOV
+        "end" get JMP
+
+        "sse-42" resolve-label
+        int-regs return-reg 42 MOV
+        "end" get JMP
+
+        "sse-41" resolve-label
+        int-regs return-reg 41 MOV
+        "end" get JMP
+
+        "ssse-3" resolve-label
+        int-regs return-reg 33 MOV
+        "end" get JMP
+
+        "sse-3" resolve-label
+        int-regs return-reg 30 MOV
+        "end" get JMP
+
+        "sse-2" resolve-label
+        int-regs return-reg 20 MOV
+        "end" get JMP
+
+        "sse-1" resolve-label
+        int-regs return-reg 10 MOV
+
+        "end" resolve-label
+    ] alien-assembly ;
 
 PRIVATE>
 
 MEMO: sse-version ( -- n )
-    sse_version
+    (sse-version) "sse-version" get string>number [ min ] when* ;
-    "sse-version" get string>number [ min ] when* ;
 
 [ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook
 
@@ -39,7 +96,18 @@ MEMO: sse-version ( -- n )
 
 HOOK: instruction-count cpu ( -- n )
 
-M: x86 instruction-count read_timestamp_counter ;
+M: x86.32 instruction-count
+    longlong { } "cdecl" [
+        RDTSC
+    ] alien-assembly ;
+
+M: x86.64 instruction-count
+    longlong { } "cdecl" [
+        RAX 0 MOV
+        RDTSC
+        RDX 32 SHL
+        RAX RDX OR
+    ] alien-assembly ;
 
 : count-instructions ( quot -- n )
-    instruction-count [ call ] dip instruction-count swap - ; inline
+    instruction-count [ call instruction-count ] dip - ; inline

basis/cpu/x86/x86.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
@@ -419,11 +419,7 @@ M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
 M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
 M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
 
-: %mov-vm-ptr ( reg -- )
+HOOK: %mov-vm-ptr cpu ( reg -- )
-    0 MOV 0 rc-absolute-cell rel-vm ;
-
-M: x86 %vm-field-ptr ( dst field -- )
-    [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
@@ -1410,18 +1406,15 @@ M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M:: x86 %load-context ( temp1 temp2 -- )
+M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
     #! Also save callstack bottom!
     temp1 "ctx" %vm-field-ptr
     temp1 temp1 [] MOV
-    ! callstack_bottom
     temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
-    temp1 1 cells [+] temp2 MOV
+    temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
-    ! datastack
+    ds-reg temp1 "datastack" context-field-offset [+] MOV
-    ds-reg temp1 2 cells [+] MOV
+    rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
-    ! retainstack
-    rs-reg temp1 3 cells [+] MOV ;
 
 M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
@@ -1429,13 +1422,10 @@ M:: x86 %save-context ( temp1 temp2 -- )
     #! all roots.
     temp1 "ctx" %vm-field-ptr
     temp1 temp1 [] MOV
-    ! callstack_top
     temp2 stack-reg cell neg [+] LEA
-    temp1 [] temp2 MOV
+    temp1 "callstack-top" context-field-offset [+] temp2 MOV
-    ! datastack
+    temp1 "datastack" context-field-offset [+] ds-reg MOV
-    temp1 2 cells [+] ds-reg MOV
+    temp1 "retainstack" context-field-offset [+] rs-reg MOV ;
-    ! retainstack
-    temp1 3 cells [+] rs-reg MOV ;
 
 M: x86 value-struct? drop t ;
 
@@ -1475,6 +1465,6 @@ enable-fixnum-log2
     ] when ;
 
 : check-sse ( -- )
-    [ { sse_version } compile ] with-optimizer
+    [ { (sse-version) } compile ] with-optimizer
     "Checking for multimedia extensions: " write sse-version
     [ sse-string write " detected" print ] [ enable-sse2 ] bi ;

basis/db/db.factor

@@ -100,10 +100,10 @@ M: object execute-statement* ( statement type -- )
     t >>bound? drop ;
 
 : sql-row ( result-set -- seq )
-    dup #columns [ row-column ] with map ;
+    dup #columns [ row-column ] with { } map-integers ;
 
 : sql-row-typed ( result-set -- seq )
-    dup #columns [ row-column-typed ] with map ;
+    dup #columns [ row-column-typed ] with { } map-integers ;
 
 : query-each ( statement quot: ( statement -- ) -- )
     over more-rows? [

basis/db/queries/queries.factor

@@ -34,7 +34,7 @@ SINGLETON: retryable
     ] 2map >>bind-params ;
     
 M: retryable execute-statement* ( statement type -- )
-    drop [ retries>> ] [
+    drop [ retries>> iota ] [
         [
             nip
             [ query-results dispose t ]

basis/db/tester/tester.factor

@@ -67,7 +67,7 @@ test-2 "TEST2" {
             test-2 ensure-table
         ] with-db
     ] [
-        10 [
+        10 iota [
             drop
             10 [
                 dup [
@@ -85,7 +85,7 @@ test-2 "TEST2" {
         ] with-db
     ] [
         <db-pool> [
-            10 [
+            10 iota [
                 10 [
                     test-1-tuple insert-tuple yield
                 ] times

basis/farkup/farkup-tests.factor

@@ -205,7 +205,7 @@ link-no-follow? off
     100 [
         drop random-markup
         [ convert-farkup drop t ] [ drop print f ] recover
-    ] all?
+    ] all-integers?
 ] unit-test
 
 [ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test

basis/fry/fry-tests.factor

@@ -64,7 +64,7 @@ SYMBOLS: a b c d e f g h ;
 [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
 
 [ { 1 2 3 } ] [
-    3 1 '[ _ [ _ + ] map ] call
+    3 1 '[ _ iota [ _ + ] map ] call
 ] unit-test
 
 [ { 1 { 2 { 3 } } } ] [

basis/generalizations/generalizations-tests.factor

@@ -64,7 +64,7 @@ IN: generalizations.tests
 { 3 5 } [ 2 nweave ] must-infer-as
 
 [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
+[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
 
 [ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test
 

basis/grouping/grouping-docs.factor

@@ -52,7 +52,7 @@ HELP: <groups>
 { $examples
     { $example
         "USING: arrays kernel prettyprint sequences grouping ;"
-        "9 >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+        "9 iota >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
     }
     { $example
         "USING: kernel prettyprint sequences grouping ;"
@@ -67,7 +67,7 @@ HELP: <sliced-groups>
 { $examples
     { $example
         "USING: arrays kernel prettyprint sequences grouping ;"
-        "9 >array 3 <sliced-groups>"
+        "9 iota >array 3 <sliced-groups>"
         "dup [ reverse! drop ] each concat >array ."
         "{ 2 1 0 5 4 3 8 7 6 }"
     }

basis/heaps/heaps-tests.factor

@@ -31,7 +31,7 @@ IN: heaps.tests
     <min-heap> [ heap-push-all ] keep heap-pop-all ;
 
 : random-alist ( n -- alist )
-    [
+    iota [
         drop 32 random-bits dup number>string
     ] H{ } map>assoc ;
 
@@ -40,16 +40,16 @@ IN: heaps.tests
 
 14 [
     [ t ] swap [ 2^ test-heap-sort ] curry unit-test
-] each
+] each-integer
 
 : test-entry-indices ( n -- ? )
     random-alist
     <min-heap> [ heap-push-all ] keep
-    data>> dup length swap [ index>> ] map sequence= ;
+    data>> dup length iota swap [ index>> ] map sequence= ;
 
 14 [
     [ t ] swap [ 2^ test-entry-indices ] curry unit-test
-] each
+] each-integer
 
 : sort-entries ( entries -- entries' )
     [ key>> ] sort-with ;
@@ -66,4 +66,4 @@ IN: heaps.tests
 
 11 [
     [ t ] swap [ 2^ delete-test sequence= ] curry unit-test
-] each
+] each-integer

basis/hints/hints.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
 combinators definitions effects fry generic generic.single
@@ -24,7 +24,7 @@ M: object specializer-declaration class ;
     "specializer" word-prop ;
 
 : make-specializer ( specs -- quot )
-    dup length <reversed>
+    dup length iota <reversed>
     [ (picker) 2array ] 2map
     [ drop object eq? not ] assoc-filter
     [ [ t ] ] [

basis/images/jpeg/jpeg.factor

@@ -137,7 +137,7 @@ TUPLE: jpeg-color-info
     data>>
     binary
     [
-        read1 [0,b)
+        read1 iota
         [   drop
             read1 jpeg> color-info>> nth clone
             read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
@@ -198,7 +198,7 @@ MEMO: yuv>bgr-matrix ( -- m )
     { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
     1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
 
-MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ;
 
 : mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
 

basis/images/png/png.factor

@@ -120,7 +120,7 @@ ERROR: unimplemented-color-type image ;
     prev width tail-slice :> b
     curr :> a
     curr width tail-slice :> x
-    x length [0,b)
+    x length iota
     filter {
         { filter-none [ drop ] }
         { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }

basis/images/processing/processing.factor

@@ -6,7 +6,7 @@ math.ranges math.vectors sequences sequences.deep fry ;
 IN: images.processing
 
 : coord-matrix ( dim -- m )
-    [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;
+    [ iota ] map first2 [ [ 2array ] with map ] curry map ;
 
 : map^2 ( m quot -- m' ) '[ _ map ] map ; inline
 : each^2 ( m quot -- m' ) '[ _ each ] each ; inline
@@ -16,7 +16,7 @@ IN: images.processing
 : matrix>image ( m -- image )
     <image> over matrix-dim >>dim
     swap flip flatten
-    [ 128 * 128 + 0 max 255 min  >fixnum ] map
+    [ 128 * 128 + 0 255 clamp >fixnum ] map
     >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;
 
 :: matrix-zoom ( m f -- m' )
@@ -30,7 +30,7 @@ IN: images.processing
 :: draw-grey ( value x,y image -- )
     x,y image image-offset 3 * { 0 1 2 }
     [
-        + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth
+        + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth
     ] with each ;
 
 :: draw-color ( value x,y color-id image -- )

basis/inspector/inspector.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables io kernel assocs math
 namespaces prettyprint prettyprint.custom prettyprint.sections
@@ -23,9 +23,7 @@ GENERIC: add-numbers ( alist -- table' )
 M: enum add-numbers ;
 
 M: assoc add-numbers
-    +number-rows+ get [
+    +number-rows+ get [ [ prefix ] map-index ] when ;
-        dup length [ prefix ] 2map
-    ] when ;
 
 TUPLE: slot-name name ;
 

basis/inverse/inverse.factor

@@ -68,7 +68,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : enough? ( stack word -- ? )
     dup deferred? [ 2drop f ] [
-        [ [ length ] [ 1quotation infer in>> ] bi* >= ]
+        [ [ length ] [ 1quotation inputs ] bi* >= ]
         [ 3drop f ] recover
     ] if ;
 
@@ -273,10 +273,10 @@ DEFER: __
     ] recover ; inline
 
 : true-out ( quot effect -- quot' )
-    out>> '[ @ _ ndrop t ] ;
+    out>> length '[ @ _ ndrop t ] ;
 
 : false-recover ( effect -- quot )
-    in>> [ ndrop f ] curry [ recover-fail ] curry ;
+    in>> length [ ndrop f ] curry [ recover-fail ] curry ;
 
 : [matches?] ( quot -- undoes?-quot )
     [undo] dup infer [ true-out ] [ false-recover ] bi curry ;

basis/io/encodings/iso2022/iso2022.factor

@@ -18,7 +18,7 @@ VALUE: jis212
 "vocab:io/encodings/iso2022/212.txt" flat-file>biassoc to: jis212
 
 VALUE: ascii
-128 unique >biassoc to: ascii
+128 iota unique >biassoc to: ascii
 
 TUPLE: iso2022-state type ;
 

basis/io/files/links/unix/unix-tests.factor

@@ -4,7 +4,7 @@ io.pathnames namespaces ;
 IN: io.files.links.unix.tests
 
 : make-test-links ( n path -- )
-    [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+    [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each-integer ]
     [ [ number>string ] dip prepend touch-file ] 2bi ; inline
 
 [ t ] [

basis/io/files/unique/unique.factor

@@ -35,8 +35,8 @@ SYMBOL: unique-retries
 : random-name ( -- string )
     unique-length get [ random-ch ] "" replicate-as ;
 
-: retry ( quot: ( -- ? )  n -- )
+: retry ( quot: ( -- ? ) n -- )
-    swap [ drop ] prepose attempt-all ; inline
+    iota swap [ drop ] prepose attempt-all ; inline
 
 : (make-unique-file) ( path prefix suffix -- path )
     '[

basis/lcs/diff2html/diff2html-tests.factor

@@ -3,4 +3,4 @@
 USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
 IN: lcs.diff2html.tests
 
-[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
+[ ] [ "hello" "heyo" [ [ 1string ] { } map-as ] bi@ diff htmlize-diff xml>string drop ] unit-test

basis/lcs/diff2html/diff2html.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2008, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lcs xml.syntax xml.writer kernel strings ;
 FROM: accessors => item>> ;

basis/lcs/lcs.factor

@@ -19,15 +19,15 @@ IN: lcs
     i 1 + j 1 + matrix nth set-nth ; inline
 
 : lcs-initialize ( |str1| |str2| -- matrix )
-    [ drop 0 <array> ] with map ;
+    iota [ drop 0 <array> ] with map ;
 
 : levenshtein-initialize ( |str1| |str2| -- matrix )
-    [ [ + ] curry map ] with map ;
+    [ iota ] bi@ [ [ + ] curry map ] with map ;
 
 :: run-lcs ( old new init step -- matrix )
     old length 1 + new length 1 + init call :> matrix
-    old length [| i |
+    old length iota [| i |
-        new length
+        new length iota
         [| j | i j matrix old new step loop-step ] each
     ] each matrix ; inline
 PRIVATE>

basis/macros/expander/expander.factor

@@ -49,7 +49,7 @@ M: wrapper expand-macros* wrapped>> literal ;
     stack get pop end
     [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
     [
-        length [ <reversed> ] keep
+        length iota [ <reversed> ] keep
         [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
     ] bi ;
 

basis/math/combinatorics/combinatorics-docs.factor

@@ -31,7 +31,7 @@ HELP: permutation
 { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
 { $examples
     { $example "USING: math.combinatorics prettyprint ;"
-        "1 3 permutation ." "{ 0 2 1 }" }
+        "1 { 0 1 2 } permutation ." "{ 0 2 1 }" }
     { $example "USING: math.combinatorics prettyprint ;"
         "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
 } ;
@@ -41,7 +41,7 @@ HELP: all-permutations
 { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
 { $examples
     { $example "USING: math.combinatorics prettyprint ;"
-        "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
+        "{ 0 1 2 } all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
 } ;
 
 HELP: each-permutation

basis/math/combinatorics/combinatorics-tests.factor

@@ -56,7 +56,7 @@ IN: math.combinatorics.tests
 [ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
 [ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
 
-[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
+[ { 5 3 2 1 } ] [ 7 iota 4 <combo> 8 combinadic ] unit-test
 [ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
 [ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
 [ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test

basis/math/combinatorics/combinatorics.factor

@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs binary-search fry kernel locals math math.order
     math.ranges namespaces sequences sorting ;
@@ -15,7 +15,7 @@ IN: math.combinatorics
 PRIVATE>
 
 : factorial ( n -- n! )
-    1 [ 1 + * ] reduce ;
+    iota 1 [ 1 + * ] reduce ;
 
 : nPk ( n k -- nPk )
     2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
@@ -46,11 +46,11 @@ PRIVATE>
     [ permutation-indices ] keep nths ;
 
 : all-permutations ( seq -- seq )
-    [ length factorial ] keep
+    [ length factorial iota ] keep
     '[ _ permutation ] map ;
 
 : each-permutation ( seq quot -- )
-    [ [ length factorial ] keep ] dip
+    [ [ length factorial iota ] keep ] dip
     '[ _ permutation @ ] each ; inline
 
 : reduce-permutations ( seq identity quot -- result )
@@ -77,7 +77,7 @@ C: <combo> combo
     dup 0 = [
         drop 1 - nip
     ] [
-        [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
+        [ iota ] 2dip '[ _ nCk _ >=< ] search nip
     ] if ;
 
 :: next-values ( a b x -- a' b' x' v )
@@ -104,7 +104,7 @@ C: <combo> combo
     [ combination-indices ] keep seq>> nths ;
 
 : combinations-quot ( seq k quot -- seq quot )
-    [ <combo> [ choose [0,b) ] keep ] dip
+    [ <combo> [ choose iota ] keep ] dip
     '[ _ apply-combination @ ] ; inline
 
 PRIVATE>

basis/math/complex/complex-tests.factor

@@ -70,4 +70,7 @@ IN: math.complex.tests
 [ ] [ C{ 1 4 } coth drop ] unit-test
 [ ] [ C{ 1 4 } cot drop ] unit-test
 
+[ t ] [ 0.0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test
+[ t ] [ 0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test
+
 [ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test