Merge branch 'master' of git://factorcode.org/git/factor into native-image-loader

basis/alien/arrays/arrays.factor

@@ -56,6 +56,9 @@ M: string-type c-type-unboxer-quot
 M: string-type c-type-getter
     drop [ alien-cell ] ;
 
+M: string-type c-type-copier
+    drop [ ] ;
+
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 

basis/alien/c-types/c-types.factor

@@ -89,6 +89,10 @@ GENERIC: c-type-getter ( name -- quot )
 
 M: c-type c-type-getter getter>> ;
 
+GENERIC: c-type-copier ( name -- quot )
+
+M: c-type c-type-copier drop [ ] ;
+
 GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
@@ -118,6 +122,9 @@ MIXIN: value-type
 MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
     [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
 
+MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
+    [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
+
 MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
     [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
     [ c-type-setter ]
@@ -139,6 +146,7 @@ PROTOCOL: c-type-protocol
     c-type-unboxer-quot
     c-type-rep
     c-type-getter
+    c-type-copier
     c-type-setter
     c-type-align
     c-type-align-first

basis/alien/data/data-docs.factor

@@ -1,7 +1,7 @@
 USING: alien alien.c-types help.syntax help.markup libc
 kernel.private byte-arrays math strings hashtables alien.syntax
 alien.strings sequences io.encodings.string debugger destructors
-vocabs.loader classes.struct ;
+vocabs.loader classes.struct quotations ;
 IN: alien.data
 
 HELP: <c-array>
@@ -44,6 +44,49 @@ HELP: malloc-byte-array
 
 { string>alien alien>string malloc-string } related-words
 
+HELP: with-scoped-allocation
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } }
+{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+    "a C type name,"
+    { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." }
+{ $examples
+    { $example
+        "USING: accessors alien.c-types alien.data
+classes.struct kernel math math.functions
+prettyprint ;
+IN: scratchpad
+
+STRUCT: point { x int } { y int } ;
+
+: scoped-allocation-test ( -- x )
+    { point } [
+        3 >>x 4 >>y
+        [ x>> sq ] [ y>> sq ] bi + sqrt
+    ] with-scoped-allocation ;
+
+scoped-allocation-test ."
+"5.0"
+    }
+} ;
+
+HELP: with-out-parameters
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } }
+{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+    "a C type name,"
+    { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ;
+
 ARTICLE: "malloc" "Manual memory management"
 "Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
 $nl

basis/alien/data/data.factor

@@ -2,7 +2,8 @@
 USING: accessors alien alien.c-types alien.arrays alien.strings
 arrays byte-arrays cpu.architecture fry io io.encodings.binary
 io.files io.streams.memory kernel libc math math.functions 
-sequences words macros combinators generalizations ;
+sequences words macros combinators generalizations
+stack-checker.dependencies combinators.short-circuit ;
 QUALIFIED: math
 IN: alien.data
 
@@ -69,7 +70,10 @@ M: value-type c-type-rep drop int-rep ;
 M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;
 
-M: value-type c-type-setter ( type -- quot )
+M: value-type c-type-copier
+    heap-size '[ _ memory>byte-array ] ;
+
+M: value-type c-type-setter
     [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
 
 M: array c-type-boxer-quot
@@ -88,14 +92,35 @@ ERROR: local-allocation-error ;
     ! to still be abl to access scope-allocated data.
     ;
 
+MACRO: (simple-local-allot) ( c-type -- quot )
+    [ depends-on-c-type ]
+    [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
+
+: [hairy-local-allot] ( c-type initial -- quot )
+    over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
+
+: hairy-local-allot? ( obj -- ? )
+    {
+        [ array? ]
+        [ length 3 = ]
+        [ second initial: eq? ]
+    } 1&& ;
+
+MACRO: (hairy-local-allot) ( obj -- quot )
+    dup hairy-local-allot?
+    [ first3 nip [hairy-local-allot] ]
+    [ '[ _ (simple-local-allot) ] ]
+    if ;
+
 MACRO: (local-allots) ( c-types -- quot )
-    [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
+    [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
 
 MACRO: box-values ( c-types -- quot )
     [ c-type-boxer-quot ] map '[ _ spread ] ;
 
 MACRO: out-parameters ( c-types -- quot )
-    [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
+    [ dup hairy-local-allot? [ first ] when ] map
+    [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
     '[ _ nkeep _ spread ] ;
 
 PRIVATE>
@@ -104,8 +129,8 @@ PRIVATE>
     [ [ (local-allots) ] [ box-values ] bi ] dip call
     (cleanup-allot) ; inline
 
-: with-out-parameters ( c-types quot finish -- values )
+: with-out-parameters ( c-types quot -- values... )
-    [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
+    [ drop (local-allots) ] [ swap out-parameters ] 2bi
     (cleanup-allot) ; inline
 
 GENERIC: binary-zero? ( value -- ? )
@@ -115,4 +140,3 @@ M: f binary-zero? drop t ; inline
 M: integer binary-zero? zero? ; inline
 M: math:float binary-zero? double>bits zero? ; inline
 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
-

basis/checksums/openssl/openssl.factor

@@ -48,9 +48,8 @@ M: evp-md-context dispose*
 : digest-value ( ctx -- value )
     handle>>
     { { int EVP_MAX_MD_SIZE } int }
-    [ EVP_DigestFinal_ex ssl-error ]
+    [ EVP_DigestFinal_ex ssl-error ] with-out-parameters
-    [ memory>byte-array ]
+    memory>byte-array ;
-    with-out-parameters ;
 
 PRIVATE>
 

basis/cocoa/messages/messages.factor

@@ -216,7 +216,7 @@ ERROR: no-objc-type name ;
     objc-methods get set-at ;
 
 : each-method-in-class ( class quot -- )
-    [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
+    [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
     over 0 = [ 3drop ] [
         [ <direct-void*-array> ] dip
         [ each ] [ drop (free) ] 2bi

basis/cocoa/nibs/nibs.factor

@@ -16,6 +16,6 @@ IN: cocoa.nibs
 
 : nib-objects ( anNSNib -- objects/f )
     f
-    { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+    { void* } [ -> instantiateNibWithOwner:topLevelObjects: ]
     with-out-parameters
     swap [ CF>array ] [ drop f ] if ;

basis/cocoa/plists/plists.factor

@@ -38,7 +38,7 @@ DEFER: plist>
 : (read-plist) ( NSData -- id )
     NSPropertyListSerialization swap kCFPropertyListImmutable f
     { void* }
-    [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
+    [ -> propertyListFromData:mutabilityOption:format:errorDescription: ]
     with-out-parameters
     [ -> release "read-plist failed" throw ] when* ;
 

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -294,14 +294,14 @@ IN: compiler.cfg.alias-analysis.tests
     V{
         T{ ##peek f 0 D 0 }
         T{ ##slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##slot-imm f 2 0 1 0 }
     }
 ] [
     V{
         T{ ##peek f 0 D 0 }
         T{ ##slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##slot-imm f 2 0 1 0 }
     } test-alias-analysis
 ] unit-test
@@ -311,7 +311,7 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
         T{ ##set-slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##slot-imm f 2 0 1 0 }
     }
 ] [
@@ -319,7 +319,7 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
         T{ ##set-slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##slot-imm f 2 0 1 0 }
     } test-alias-analysis
 ] unit-test
@@ -330,7 +330,7 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##peek f 1 D 1 }
         T{ ##peek f 2 D 2 }
         T{ ##set-slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##set-slot-imm f 2 0 1 0 }
     }
 ] [
@@ -339,7 +339,7 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##peek f 1 D 1 }
         T{ ##peek f 2 D 2 }
         T{ ##set-slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##set-slot-imm f 2 0 1 0 }
     } test-alias-analysis
 ] unit-test
@@ -348,14 +348,14 @@ IN: compiler.cfg.alias-analysis.tests
     V{
         T{ ##peek f 0 D 0 }
         T{ ##slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##set-slot-imm f 1 0 1 0 }
     }
 ] [
     V{
         T{ ##peek f 0 D 0 }
         T{ ##slot-imm f 1 0 1 0 }
-        T{ ##alien-invoke f "free" }
+        T{ ##alien-invoke f { } { } { } 0 0 "free" }
         T{ ##set-slot-imm f 1 0 1 0 }
     } test-alias-analysis
 ] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -224,13 +224,13 @@ M: vreg-insn analyze-aliases
     ! anywhere its used as a tagged pointer. Boxing allocates
     ! a new value, except boxing instructions haven't been
     ! inserted yet.
-    dup defs-vreg [
+    dup [
-        over defs-vreg-rep { int-rep tagged-rep } member?
+        { int-rep tagged-rep } member?
         [ set-heap-ac ] [ set-new-ac ] if
-    ] when* ;
+    ] each-def-rep ;
 
 M: ##phi analyze-aliases
-    dup defs-vreg set-heap-ac ;
+    dup dst>> set-heap-ac ;
 
 M: ##allocation analyze-aliases
     #! A freshly allocated object is distinct from any other

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

@@ -21,9 +21,9 @@ M:: ##local-allot compute-stack-frame* ( insn -- )
     allot-area-align [ a max ] change
     allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
 
-M: ##stack-frame compute-stack-frame*
+M: alien-call-insn compute-stack-frame*
     frame-required
-    stack-frame>> param-area-size [ max ] change ;
+    stack-size>> param-area-size [ max ] change ;
 
 : vm-frame-required ( -- )
     frame-required
@@ -33,8 +33,8 @@ M: ##call-gc compute-stack-frame* drop vm-frame-required ;
 M: ##box compute-stack-frame* drop vm-frame-required ;
 M: ##unbox compute-stack-frame* drop vm-frame-required ;
 M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
-M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
+M: ##callback-inputs compute-stack-frame* drop vm-frame-required ;
-M: ##end-callback compute-stack-frame* drop vm-frame-required ;
+M: ##callback-outputs compute-stack-frame* drop vm-frame-required ;
 M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
 M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
 

basis/compiler/cfg/builder/alien/alien.factor

@@ -14,6 +14,19 @@ compiler.cfg.registers compiler.cfg.hats ;
 FROM: compiler.errors => no-such-symbol no-such-library ;
 IN: compiler.cfg.builder.alien
 
+: with-param-regs* ( quot -- reg-values stack-values )
+    '[
+        V{ } clone reg-values set
+        V{ } clone stack-values set
+        @
+        reg-values get
+        stack-values get
+        stack-params get
+        struct-return-area get
+    ] with-param-regs
+    struct-return-area set
+    stack-params set ; inline
+
 : unbox-parameters ( parameters -- vregs reps )
     [
         [ length iota <reversed> ] keep
@@ -30,32 +43,23 @@ IN: compiler.cfg.builder.alien
         ] keep
     ] [ drop f ] if ;
 
-: caller-parameter ( vreg rep on-stack? -- insn )
-    [ dup reg-class-of reg-class-full? ] dip or
-    [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
-    [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
-    if ;
-
 : (caller-parameters) ( vregs reps -- )
-    ! Place ##store-stack-param instructions first. This ensures
+    [ first2 next-parameter ] 2each ;
-    ! that no registers are used after the ##store-reg-param
-    ! instructions.
-    [ first2 caller-parameter ] 2map
-    [ ##store-stack-param? ] partition [ % ] bi@ ;
 
-: caller-parameters ( params -- stack-size )
+: caller-parameters ( params -- reg-inputs stack-inputs )
     [ abi>> ] [ parameters>> ] [ return>> ] tri
     '[ 
         _ unbox-parameters
         _ prepare-struct-caller struct-return-area set
         (caller-parameters)
-        stack-params get
+    ] with-param-regs* ;
-        struct-return-area get
-    ] with-param-regs
-    struct-return-area set ;
 
-: box-return* ( node -- )
+: prepare-caller-return ( params -- reg-outputs )
-    return>> [ ] [ base-type box-return ds-push ] if-void ;
+    return>> [ { } ] [ base-type load-return ] if-void ;
+
+: caller-stack-frame ( params -- cleanup stack-size )
+    [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
+    stack-params get ;
 
 GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
 
@@ -79,79 +83,91 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
     } 2cleave
     4array ;
 
-: alien-invoke-dlsym ( params -- symbols dll )
+: caller-linkage ( params -- symbols dll )
     [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
     [ library>> load-library ]
     bi 2dup check-dlsym ;
 
-: emit-stack-frame ( stack-size params -- )
+: caller-return ( params -- )
-    [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
+    return>> [ ] [
-    [ drop ##stack-frame ]
+        [
-    2bi ;
+            building get last reg-outputs>>
+            flip [ { } { } ] [ first2 ] if-empty
+        ] dip
+        base-type box-return ds-push
+    ] if-void ;
 
 M: #alien-invoke emit-node
     params>>
+    [
         {
             [ caller-parameters ]
-        [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
+            [ prepare-caller-return ]
-        [ emit-stack-frame ]
+            [ caller-stack-frame ]
-        [ box-return* ]
+            [ caller-linkage ]
-    } cleave ;
+        } cleave
+        <gc-map> ##alien-invoke
+    ]
+    [ caller-return ]
+    bi ;
 
 M: #alien-indirect emit-node ( node -- )
     params>>
     [
-        ds-pop ^^unbox-any-c-ptr
+        [ ds-pop ^^unbox-any-c-ptr ] dip
-        [ caller-parameters ] dip
+        [ caller-parameters ]
+        [ prepare-caller-return ]
+        [ caller-stack-frame ] tri
         <gc-map> ##alien-indirect
     ]
-    [ emit-stack-frame ]
+    [ caller-return ]
-    [ box-return* ]
+    bi ;
-    tri ;
 
 M: #alien-assembly emit-node
-    params>> {
+    params>>
+    [
+        {
             [ caller-parameters ]
-        [ quot>> <gc-map> ##alien-assembly ]
+            [ prepare-caller-return ]
-        [ emit-stack-frame ]
+            [ caller-stack-frame ]
-        [ box-return* ]
+            [ quot>> ]
-    } cleave ;
+        } cleave <gc-map> ##alien-assembly
+    ]
+    [ caller-return ]
+    bi ;
 
-: callee-parameter ( rep on-stack? -- dst insn )
+: callee-parameter ( rep on-stack? -- dst )
-    [ next-vreg dup ] 2dip
+    [ next-vreg dup ] 2dip next-parameter ;
-    [ dup reg-class-of reg-class-full? ] dip or
-    [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
-    [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
-    if ;
 
 : prepare-struct-callee ( c-type -- vreg )
     large-struct?
-    [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
+    [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ;
 
 : (callee-parameters) ( params -- vregs reps )
     [ flatten-parameter-type ] map
-    [
+    [ [ [ first2 callee-parameter ] map ] map ]
-        [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
-        concat [ ##load-reg-param? ] partition [ % ] bi@
-    ]
     [ [ keys ] map ]
     bi ;
 
 : box-parameters ( vregs reps params -- )
-    ##begin-callback [ box-parameter ds-push ] 3each ;
+    parameters>> [ base-type box-parameter ds-push ] 3each ;
 
-: callee-parameters ( params -- stack-size )
+: callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
     [ abi>> ] [ return>> ] [ parameters>> ] tri
     '[ 
         _ prepare-struct-callee struct-return-area set
-        _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
+        _ [ base-type ] map (callee-parameters)
-        stack-params get
+    ] with-param-regs* ;
-        struct-return-area get
-    ] with-param-regs
-    struct-return-area set ;
 
-: callback-stack-cleanup ( stack-size params -- )
+: callee-return ( params -- reg-inputs )
-    [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
+    return>> [ { } ] [
+        [ ds-pop ] dip
+        base-type unbox-return store-return
+    ] if-void ;
+
+: callback-stack-cleanup ( params -- )
+    [ xt>> ]
+    [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
     "stack-cleanup" set-word-prop ;
 
 : needs-frame-pointer ( -- )
@@ -165,20 +181,15 @@ M: #alien-callback emit-node
         begin-word
 
         {
-            [ callee-parameters ]
+            [ callee-parameters ##callback-inputs ]
+            [ box-parameters ]
             [
                 [
                     make-kill-block
                     quot>> ##alien-callback
                 ] emit-trivial-block
             ]
-            [
+            [ callee-return ##callback-outputs ]
-                return>> [ ##end-callback ] [
-                    [ ds-pop ] dip
-                    ##end-callback
-                    base-type unbox-return
-                ] if-void
-            ]
             [ callback-stack-cleanup ]
         } cleave
 

basis/compiler/cfg/builder/alien/boxing/boxing.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs classes.struct fry
+USING: accessors alien.c-types arrays assocs combinators
-kernel layouts locals math namespaces sequences
+classes.struct fry kernel layouts locals math namespaces
-sequences.generalizations system
+sequences sequences.generalizations system
 compiler.cfg.builder.alien.params compiler.cfg.hats
-compiler.cfg.instructions cpu.architecture ;
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.intrinsics.allot cpu.architecture ;
 IN: compiler.cfg.builder.alien.boxing
 
 SYMBOL: struct-return-area
@@ -45,15 +46,22 @@ M: struct-c-type flatten-c-type
 GENERIC: unbox ( src c-type -- vregs reps )
 
 M: c-type unbox
-    [ unboxer>> ] [ rep>> ] bi
+    [ rep>> ] [ unboxer>> ] bi
-    [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
+    [
+        {
+            ! { "to_float" [ drop ] }
+            ! { "to_double" [ drop ] }
+            ! { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
+            [ swap ^^unbox ]
+        } case 1array
+    ]
+    [ drop f 2array 1array ] 2bi ;
 
 M: long-long-type unbox
-    [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
+    [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array
-    0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
     int-rep long-long-on-stack? 2array dup 2array ;
 
-M: struct-c-type unbox ( src c-type -- vregs )
+M: struct-c-type unbox ( src c-type -- vregs reps )
     [ ^^unbox-any-c-ptr ] dip explode-struct ;
 
 : frob-struct ( c-type -- c-type )
@@ -73,73 +81,77 @@ M: struct-c-type unbox-parameter
         1array { { int-rep f } }
     ] if ;
 
-GENERIC: unbox-return ( src c-type -- )
+: store-return ( vregs reps -- triples )
+    [ [ dup next-return-reg 3array ] 2map ] with-return-regs ;
 
-: store-return ( vregs reps -- )
+GENERIC: unbox-return ( src c-type -- vregs reps )
-    [
-        [ [ next-return-reg ] keep ##store-reg-param ] 2each
-    ] with-return-regs ;
 
-: (unbox-return) ( src c-type -- vregs reps )
+M: abstract-c-type unbox-return
     ! Don't care about on-stack? flag when looking at return
     ! values.
     unbox keys ;
 
-M: c-type unbox-return (unbox-return) store-return ;
-
-M: long-long-type unbox-return (unbox-return) store-return ;
-
 M: struct-c-type unbox-return
     dup return-struct-in-registers?
-    [ (unbox-return) store-return ]
+    [ call-next-method ]
-    [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
+    [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ;
 
 GENERIC: flatten-parameter-type ( c-type -- reps )
 
-M: c-type flatten-parameter-type flatten-c-type ;
+M: abstract-c-type flatten-parameter-type flatten-c-type ;
-
-M: long-long-type flatten-parameter-type flatten-c-type ;
 
 M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
 
 GENERIC: box ( vregs reps c-type -- dst )
 
 M: c-type box
-    [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* <gc-map> ^^box ;
+    [ [ first ] bi@ ] [ boxer>> ] bi*
+    {
+        ! { "from_float" [ drop ] }
+        ! { "from_double" [ drop ] }
+        ! { "allot_alien" [ drop ^^box-alien ] }
+        [ swap <gc-map> ^^box ]
+    } case ;
 
 M: long-long-type box
-    [ first2 ] [ drop ] [ boxer>> ] tri* <gc-map> ^^box-long-long ;
+    [ first2 ] [ drop ] [ boxer>> ] tri*
+    <gc-map> ^^box-long-long ;
 
 M: struct-c-type box
-    '[ _ heap-size <gc-map> ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
+    '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
     implode-struct ;
 
 GENERIC: box-parameter ( vregs reps c-type -- dst )
 
-M: c-type box-parameter box ;
+M: abstract-c-type box-parameter box ;
-
-M: long-long-type box-parameter box ;
 
 M: struct-c-type box-parameter
     dup value-struct?
     [ [ [ drop first ] dip explode-struct keys ] keep ] unless
     box ;
 
-GENERIC: box-return ( c-type -- dst )
+GENERIC: load-return ( c-type -- triples )
 
-: load-return ( c-type -- vregs reps )
+M: abstract-c-type load-return
     [
         flatten-c-type keys
-        [ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
+        [ [ next-vreg ] dip dup next-return-reg 3array ] map
     ] with-return-regs ;
 
-M: c-type box-return [ load-return ] keep box ;
+M: struct-c-type load-return
+    dup return-struct-in-registers?
+    [ call-next-method ] [ drop { } ] if ;
 
-M: long-long-type box-return [ load-return ] keep box ;
+GENERIC: box-return ( vregs reps c-type -- dst )
+
+M: abstract-c-type box-return box ;
 
 M: struct-c-type box-return
-    [
     dup return-struct-in-registers?
-        [ load-return ]
+    [ call-next-method ]
-        [ [ struct-return-area get ] dip explode-struct keys ] if
+    [
-    ] keep box ;
+        [
+            [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
+            explode-struct keys
+        ] keep box
+    ] if ;

basis/compiler/cfg/builder/alien/params/params.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cpu.architecture fry kernel layouts math math.order
-namespaces sequences vectors assocs ;
+namespaces sequences vectors assocs arrays ;
 IN: compiler.cfg.builder.alien.params
 
 SYMBOL: stack-params
@@ -47,6 +47,13 @@ M: double-rep next-reg-param
 : with-param-regs ( abi quot -- )
     '[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
 
+SYMBOLS: stack-values reg-values ;
+
+: next-parameter ( vreg rep on-stack? -- )
+    [ dup dup reg-class-of reg-class-full? ] dip or
+    [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if
+    [ 3array ] dip get push ;
+
 : next-return-reg ( rep -- reg ) reg-class-of get pop ;
 
 : with-return-regs ( quot -- )

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -46,7 +46,7 @@ M: ##phi visit-insn
     ] if ;
 
 M: vreg-insn visit-insn
-    defs-vreg [ dup record-copy ] when* ;
+    defs-vregs [ dup record-copy ] each ;
 
 M: insn visit-insn drop ;
 

basis/compiler/cfg/dce/dce.factor

@@ -28,11 +28,11 @@ SYMBOL: allocations
 
 GENERIC: build-liveness-graph ( insn -- )
 
-: add-edges ( insn register -- )
+: add-edges ( uses def -- )
-    [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+    liveness-graph get [ union ] change-at ;
 
 : setter-liveness-graph ( insn vreg -- )
-    dup allocation? [ add-edges ] [ 2drop ] if ;
+    dup allocation? [ [ uses-vregs ] dip add-edges ] [ 2drop ] if ;
 
 M: ##set-slot build-liveness-graph
     dup obj>> setter-liveness-graph ;
@@ -50,7 +50,7 @@ M: ##allot build-liveness-graph
     [ dst>> allocations get adjoin ] [ call-next-method ] bi ;
 
 M: vreg-insn build-liveness-graph
-    dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
+    [ uses-vregs ] [ defs-vregs ] bi [ add-edges ] with each ;
 
 M: insn build-liveness-graph drop ;
 
@@ -83,14 +83,9 @@ M: ##write-barrier compute-live-vregs
 M: ##write-barrier-imm compute-live-vregs
     dup src>> setter-live-vregs ;
 
-M: ##fixnum-add compute-live-vregs record-live ;
+M: flushable-insn compute-live-vregs drop ;
 
-M: ##fixnum-sub compute-live-vregs record-live ;
+M: vreg-insn compute-live-vregs record-live ;
-
-M: ##fixnum-mul compute-live-vregs record-live ;
-
-M: vreg-insn compute-live-vregs
-    dup defs-vreg [ drop ] [ record-live ] if ;
 
 M: insn compute-live-vregs drop ;
 
@@ -104,15 +99,9 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
 
 M: ##write-barrier-imm live-insn? src>> live-vreg? ;
 
-M: ##fixnum-add live-insn? drop t ;
+M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
 
-M: ##fixnum-sub live-insn? drop t ;
+M: insn live-insn? drop t ;
-
-M: ##fixnum-mul live-insn? drop t ;
-
-M: vreg-insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
-
-M: insn live-insn? defs-vreg drop t ;
 
 : eliminate-dead-code ( cfg -- cfg' )
     ! Even though we don't use predecessors directly, we depend

basis/compiler/cfg/debugger/debugger.factor

@@ -121,7 +121,7 @@ M: rs-loc pprint* \ R pprint-loc ;
     post-order [
         instructions>> [
             [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
-            [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
+            [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
-            bi [ suffix ] when*
+            bi append
         ] map concat
     ] map concat >hashtable representations set ;

basis/compiler/cfg/def-use/def-use-tests.factor

@@ -33,4 +33,4 @@ V{
 5 6 edge
 
 cfg new 1 get >>entry 0 set
-[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
+[ ] [ 0 get compute-defs ] unit-test

basis/compiler/cfg/def-use/def-use.factor

@@ -9,16 +9,14 @@ FROM: namespaces => set ;
 FROM: sets => members ;
 IN: compiler.cfg.def-use
 
-GENERIC: defs-vreg ( insn -- vreg/f )
+GENERIC: defs-vregs ( insn -- seq )
 GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: insn defs-vreg drop f ;
+M: insn defs-vregs drop { } ;
 M: insn temp-vregs drop { } ;
 M: insn uses-vregs drop { } ;
 
-M: ##phi uses-vregs inputs>> values ;
-
 <PRIVATE
 
 : slot-array-quot ( slots -- quot )
@@ -29,33 +27,55 @@ M: ##phi uses-vregs inputs>> values ;
         [ '[ _ cleave _ narray ] ]
     } case ;
 
-: define-defs-vreg-method ( insn -- )
+: define-vregs-method ( insn slots word -- )
-    dup insn-def-slot dup [
+    [ [ drop ] ] dip '[
-        [ \ defs-vreg create-method ]
+        [ _ create-method ]
-        [ name>> reader-word 1quotation ] bi*
+        [ [ name>> ] map slot-array-quot ] bi*
         define
-    ] [ 2drop ] if ;
+    ] if-empty ; inline
+
+: define-defs-vregs-method ( insn -- )
+    dup insn-def-slots \ defs-vregs define-vregs-method ;
 
 : define-uses-vregs-method ( insn -- )
-    dup insn-use-slots [ drop ] [
+    dup insn-use-slots \ uses-vregs define-vregs-method ;
-        [ \ uses-vregs create-method ]
-        [ [ name>> ] map slot-array-quot ] bi*
-        define
-    ] if-empty ;
 
 : define-temp-vregs-method ( insn -- )
-    dup insn-temp-slots [ drop ] [
+    dup insn-temp-slots \ temp-vregs define-vregs-method ;
-        [ \ temp-vregs create-method ]
-        [ [ name>> ] map slot-array-quot ] bi*
-        define
-    ] if-empty ;
 
 PRIVATE>
 
+CONSTANT: special-vreg-insns
+{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs }
+
+M: ##phi defs-vregs dst>> 1array ;
+
+M: alien-call-insn defs-vregs
+    reg-outputs>> [ first ] map ;
+
+M: ##callback-inputs defs-vregs
+    [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
+
+M: ##callback-outputs defs-vregs drop { } ;
+
+M: ##phi uses-vregs inputs>> values ;
+
+M: alien-call-insn uses-vregs
+    [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
+
+M: ##alien-indirect uses-vregs
+    [ call-next-method ] [ src>> ] bi prefix ;
+
+M: ##callback-inputs uses-vregs
+    drop { } ;
+
+M: ##callback-outputs uses-vregs
+    reg-inputs>> [ first ] map ;
+
 [
     insn-classes get
-    [ [ define-defs-vreg-method ] each ]
+    [ special-vreg-insns diff [ define-defs-vregs-method ] each ]
-    [ { ##phi } diff [ define-uses-vregs-method ] each ]
+    [ special-vreg-insns diff [ define-uses-vregs-method ] each ]
     [ [ define-temp-vregs-method ] each ]
     tri
 ] with-compilation-unit
@@ -69,7 +89,7 @@ SYMBOLS: defs insns uses ;
 : insn-of ( vreg -- insn ) insns get at ;
 
 : set-def-of ( obj insn assoc -- )
-    swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
+    swap defs-vregs [ swap set-at ] with with each ;
 
 : compute-defs ( cfg -- )
     H{ } clone [
@@ -89,16 +109,3 @@ SYMBOLS: defs insns uses ;
             ] each
         ] each-basic-block
     ] keep insns set ;
-
-:: compute-uses ( cfg -- )
-    ! Here, a phi node uses its argument in the block that it comes from.
-    H{ } clone :> use
-    cfg [| block |
-        block instructions>> [
-            dup ##phi?
-            [ inputs>> [ use adjoin-at ] assoc-each ]
-            [ uses-vregs [ block swap use adjoin-at ] each ]
-            if
-        ] each
-    ] each-basic-block
-    use [ members ] assoc-map uses set ;

basis/compiler/cfg/dependence/dependence.factor

@@ -24,7 +24,7 @@ TUPLE: node
     children parent
     registers parent-index ;
 
-M: node equal?  [ number>> ] bi@ = ;
+M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ;
 
 M: node hashcode* nip number>> ;
 
@@ -45,7 +45,7 @@ M: node hashcode* nip number>> ;
     ! we only care about local def-use
     H{ } clone :> definers
     nodes [| node |
-        node insn>> defs-vreg [ node swap definers set-at ] when*
+        node insn>> defs-vregs [ node swap definers set-at ] each
         node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
     ] each ;
 
@@ -56,12 +56,9 @@ UNION: slot-insn
 
 UNION: memory-insn
     ##load-memory ##load-memory-imm
-    ##store-memory ##store-memory-imm ;
+    ##store-memory ##store-memory-imm
-
+    alien-call-insn
-UNION: alien-call-insn
+    slot-insn ;
-    ##save-context
-    ##alien-invoke ##alien-indirect ##alien-callback
-    ##unary-float-function ##binary-float-function ;
 
 : chain ( node var -- )
     dup get [
@@ -71,24 +68,14 @@ UNION: alien-call-insn
 
 GENERIC: add-control-edge ( node insn -- )
 
-M: stack-insn add-control-edge
+M: stack-insn add-control-edge loc>> chain ;
-    loc>> chain ;
 
-M: memory-insn add-control-edge
+M: memory-insn add-control-edge drop memory-insn chain ;
-    drop memory-insn chain ;
-
-M: slot-insn add-control-edge
-    drop slot-insn chain ;
-
-M: alien-call-insn add-control-edge
-    drop alien-call-insn chain ;
 
 M: object add-control-edge 2drop ;
 
 : add-control-edges ( nodes -- )
-    [
+    [ [ dup insn>> add-control-edge ] each ] with-scope ;
-        [ dup insn>> add-control-edge ] each
-    ] with-scope ;
 
 : set-follows ( nodes -- )
     [

basis/compiler/cfg/finalization/finalization.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.gc-checks
+USING: kernel compiler.cfg.representations
-compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.scheduling compiler.cfg.gc-checks
-compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.linear-scan compiler.cfg.scheduling
+compiler.cfg.build-stack-frame compiler.cfg.linear-scan
 compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- cfg' )
     select-representations
-    ! schedule-instructions
+    schedule-instructions
     insert-gc-checks
     dup compute-uninitialized-sets
     insert-save-contexts

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -31,6 +31,7 @@ GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index
     seen-allocation? [ call-index , ] when
     insn-index 1 + f ;
 
+M: ##callback-inputs gc-check-offsets* gc-check-here ;
 M: ##phi gc-check-offsets* gc-check-here ;
 M: gc-map-insn gc-check-offsets* gc-check-here ;
 M: ##allocation gc-check-offsets* 3drop t ;
@@ -61,9 +62,7 @@ M: insn gc-check-offsets* 2drop ;
 GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
-
 M: ##box-alien allocation-size* drop 5 cells ;
-
 M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
 : allocation-size ( insns -- n )

basis/compiler/cfg/hats/hats.factor

@@ -36,7 +36,7 @@ IN: compiler.cfg.hats
 PRIVATE>
 
 insn-classes get [
-    dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+    dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
     [ define-hat ] [ drop ] if
 ] each
 

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

@@ -36,11 +36,8 @@ TUPLE: insn-slot-spec type name rep ;
         ] reduce drop
     ] { } make ;
 
-: find-def-slot ( slots -- slot/f )
+: insn-def-slots ( class -- slot/f )
-    [ type>> def eq? ] find nip ;
+    "insn-slots" word-prop [ type>> def eq? ] filter ;
-
-: insn-def-slot ( class -- slot/f )
-    "insn-slots" word-prop find-def-slot ;
 
 : insn-use-slots ( class -- slots )
     "insn-slots" word-prop [ type>> use eq? ] filter ;
@@ -59,8 +56,11 @@ TUPLE: insn-slot-spec type name rep ;
 : vreg-insn-word ( -- word )
     "vreg-insn" "compiler.cfg.instructions" lookup ;
 
-: pure-insn-word ( -- word )
+: flushable-insn-word ( -- word )
-    "pure-insn" "compiler.cfg.instructions" lookup ;
+    "flushable-insn" "compiler.cfg.instructions" lookup ;
+
+: foldable-insn-word ( -- word )
+    "foldable-insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
     boa-effect in>> but-last { } <effect> ;
@@ -68,18 +68,14 @@ TUPLE: insn-slot-spec type name rep ;
 : uses-vregs? ( specs -- ? )
     [ type>> { def use temp } member-eq? ] any? ;
 
-: insn-superclass ( pure? specs -- superclass )
+: define-insn-tuple ( class superclass specs -- )
-    pure-insn-word swap uses-vregs? vreg-insn-word insn-word ? ? ;
-
-: define-insn-tuple ( class pure? specs -- )
-    [ insn-superclass ] keep
     [ name>> ] map "insn#" suffix define-tuple-class ;
 
 : define-insn-ctor ( class specs -- )
     [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
     [ name>> ] map { } <effect> define-declared ;
 
-: define-insn ( class pure? specs -- )
+: define-insn ( class superclass specs -- )
     parse-insn-slot-specs
     {
         [ nip "insn-slots" set-word-prop ]
@@ -89,6 +85,14 @@ TUPLE: insn-slot-spec type name rep ;
         [ nip define-insn-ctor ]
     } 3cleave ;
 
-SYNTAX: INSN: CREATE-CLASS f ";" parse-tokens define-insn ;
+SYNTAX: INSN:
+    CREATE-CLASS insn-word ";" parse-tokens define-insn ;
 
-SYNTAX: PURE-INSN: CREATE-CLASS t ";" parse-tokens define-insn ;
+SYNTAX: VREG-INSN:
+    CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: FLUSHABLE-INSN:
+    CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: FOLDABLE-INSN:
+    CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ;

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

@@ -62,13 +62,11 @@ IN: compiler.cfg.intrinsics.allot
 
 : bytes>cells ( m -- n ) cell align cell /i ;
 
-: ^^allot-byte-array ( n -- dst )
+: ^^allot-byte-array ( len -- dst )
-    16 + byte-array ^^allot ;
+    dup 16 + byte-array ^^allot [ byte-array store-length ] keep ;
 
 : emit-allot-byte-array ( len -- dst )
-    ds-drop
+    ds-drop ^^allot-byte-array dup ds-push ;
-    dup ^^allot-byte-array
-    [ byte-array store-length ] [ ds-push ] [ ] tri ;
 
 : emit-(byte-array) ( node -- )
     dup node-input-infos first literal>> dup expand-(byte-array)?

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -48,39 +48,59 @@ IN: compiler.cfg.linear-scan.allocation
     2dup spill-at-sync-point?
     [ swap n>> spill f ] [ 2drop t ] if ;
 
-GENERIC: handle-progress* ( obj -- )
+: handle-interval ( live-interval -- )
+    [ start>> deactivate-intervals ]
+    [ start>> activate-intervals ]
+    [ assign-register ]
+    tri ;
 
-M: live-interval handle-progress* drop ;
+: (handle-sync-point) ( sync-point -- )
-
-M: sync-point handle-progress*
     active-intervals get values
     [ [ spill-at-sync-point ] with filter! drop ] with each ;
 
-:: handle-progress ( n obj -- )
+: handle-sync-point ( sync-point -- )
-    n progress set
+    [ n>> deactivate-intervals ]
-    n deactivate-intervals
+    [ (handle-sync-point) ]
-    obj handle-progress*
+    [ n>> activate-intervals ]
-    n activate-intervals ;
+    tri ;
 
-GENERIC: handle ( obj -- )
+:: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- )
-
-M: live-interval handle ( live-interval -- )
-    [ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
-
-M: sync-point handle ( sync-point -- )
-    [ n>> ] keep handle-progress ;
-
-: smallest-heap ( heap1 heap2 -- heap )
-    ! If heap1 and heap2 have the same key, favors heap1.
     {
-        { [ dup heap-empty? ] [ drop ] }
+        {
-        { [ over heap-empty? ] [ nip ] }
+            [ unhandled-intervals heap-empty? ]
-        [ [ [ heap-peek nip ] bi@ <= ] most ]
+            [ unhandled-sync-points heap-pop drop handle-sync-point ]
+        }
+        {
+            [ unhandled-sync-points heap-empty? ]
+            [ unhandled-intervals heap-pop drop handle-interval ]
+        }
+        [
+            unhandled-intervals heap-peek :> ( i ik )
+            unhandled-sync-points heap-peek :> ( s sk )
+            {
+                {
+                    [ ik sk < ]
+                    [ unhandled-intervals heap-pop* i handle-interval ]
+                }
+                {
+                    [ ik sk > ]
+                    [ unhandled-sync-points heap-pop* s handle-sync-point ]
+                }
+                [
+                    unhandled-intervals heap-pop*
+                    i handle-interval
+                    s (handle-sync-point)
+                ]
+            } cond
+        ]
     } cond ;
 
-: (allocate-registers) ( -- )
+: (allocate-registers) ( unhandled-intervals unhandled-sync-points -- )
-    unhandled-intervals get unhandled-sync-points get smallest-heap
+    2dup [ heap-empty? ] both? [ 2drop ] [
-    dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+        [ (allocate-registers-step) ]
+        [ (allocate-registers) ]
+        2bi
+    ] if ;
 
 : finish-allocation ( -- )
     active-intervals inactive-intervals
@@ -89,6 +109,6 @@ M: sync-point handle ( sync-point -- )
 : allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
     init-allocator
     init-unhandled
-    (allocate-registers)
+    unhandled-intervals get unhandled-sync-points get (allocate-registers)
     finish-allocation
     handled-intervals get ;

basis/compiler/cfg/linear-scan/allocation/state/state.factor

@@ -90,6 +90,7 @@ ERROR: register-already-used live-interval ;
     ! Any active intervals which have ended are moved to handled
     ! Any active intervals which cover the current position
     ! are moved to inactive
+    dup progress set
     active-intervals {
         { [ 2dup finished? ] [ finish ] }
         { [ 2dup covers? not ] [ deactivate ] }

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -11,6 +11,7 @@ compiler.cfg.rpo
 compiler.cfg.debugger
 compiler.cfg.def-use
 compiler.cfg.comparisons
+compiler.cfg.ssa.destruction
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
@@ -25,6 +26,36 @@ IN: compiler.cfg.linear-scan.tests
 check-allocation? on
 check-numbering? on
 
+! Live interval calculation
+
+! A value is defined and never used; make sure it has the right
+! live range
+V{
+    T{ ##load-integer f 1 0 }
+    T{ ##replace-imm f D 0 "hi" }
+    T{ ##branch }
+} 0 test-bb
+
+: test-live-intervals ( -- )
+    cfg new 0 get >>entry
+    [ cfg set ] [ number-instructions ] [ compute-live-intervals ] tri
+    2drop ;
+
+[ ] [
+    H{
+        { 1 int-rep }
+    } representations set
+    H{
+        { 1 1 }
+    } leader-map set
+    test-live-intervals
+] unit-test
+
+[ 0 0 ] [
+    1 live-intervals get at [ start>> ] [ end>> ] bi
+] unit-test
+
+! Live range and interval splitting
 [
     { T{ live-range f 1 10 } T{ live-range f 15 15 } }
     { T{ live-range f 16 20 } }

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -54,8 +54,11 @@ M: live-interval covers? ( insn# live-interval -- ? )
         covers?
     ] if ;
 
+: (find-use) ( insn# live-interval -- vreg-use )
+    uses>> [ n>> <=> ] with search nip ;
+
 :: find-use ( insn# live-interval -- vreg-use )
-    insn# live-interval uses>> [ n>> <=> ] with search nip
+    insn# live-interval (find-use)
     dup [ dup n>> insn# = [ drop f ] unless ] when ;
 
 : add-new-range ( from to live-interval -- )
@@ -122,7 +125,7 @@ M: insn compute-live-intervals* drop ;
 
 M: vreg-insn compute-live-intervals* ( insn -- )
     dup insn#>>
-    [ [ defs-vreg ] dip '[ _ record-def ] when* ]
+    [ [ defs-vregs ] dip '[ _ record-def ] each ]
     [ [ uses-vregs ] dip '[ _ record-use ] each ]
     [ [ temp-vregs ] dip '[ _ record-temp ] each ]
     2tri ;

basis/compiler/cfg/liveness/liveness.factor

@@ -16,7 +16,7 @@ BACKWARD-ANALYSIS: live
 GENERIC: visit-insn ( live-set insn -- live-set )
 
 : kill-defs ( live-set insn -- live-set )
-    defs-vreg [ over delete-at ] when* ; inline
+    defs-vregs [ over delete-at ] each ; inline
 
 : gen-uses ( live-set insn -- live-set )
     uses-vregs [ over conjoin ] each ; inline

basis/compiler/cfg/renaming/functor/functor.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 arrays assocs fry functors generic.parser
 kernel lexer namespaces parser sequences slots words sets
@@ -22,22 +22,43 @@ GENERIC: rename-insn-defs ( insn -- )
 
 M: insn rename-insn-defs drop ;
 
-insn-classes get [ insn-def-slot ] filter [
+insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
     [ \ rename-insn-defs create-method-in ]
-    [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
+    [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
     define
 ] each
 
+M: ##phi rename-insn-defs DEF-QUOT change-dst drop ;
+
+M: alien-call-insn rename-insn-defs
+    [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ;
+
+M: ##callback-inputs rename-insn-defs
+    [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
+    [ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs
+    drop ;
+
 GENERIC: rename-insn-uses ( insn -- )
 
 M: insn rename-insn-uses drop ;
 
-insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
+insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
     [ \ rename-insn-uses create-method-in ]
     [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
     define
 ] each
 
+M: alien-call-insn rename-insn-uses
+    [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
+    [ [ first3 USE-QUOT 2dip 3array ] map ] change-stack-inputs
+    drop ;
+
+M: ##alien-indirect rename-insn-uses
+    USE-QUOT change-src call-next-method ;
+
+M: ##callback-outputs rename-insn-uses
+    [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
+
 M: ##phi rename-insn-uses
     [ USE-QUOT assoc-map ] change-inputs drop ;
 

basis/compiler/cfg/representations/coalescing/coalescing.factor

@@ -12,7 +12,7 @@ SYMBOL: components
 : init-components ( cfg components -- )
     '[
         instructions>> [
-            defs-vreg [ _ add-atom ] when*
+            defs-vregs [ _ add-atom ] each
         ] each
     ] each-basic-block ;
 

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -1,19 +1,20 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences arrays fry namespaces generic
 words sets combinators generalizations sequences.generalizations
 cpu.architecture compiler.units compiler.cfg.utilities
 compiler.cfg compiler.cfg.rpo compiler.cfg.instructions
 compiler.cfg.def-use ;
-FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
+FROM: compiler.cfg.instructions.syntax => insn-def-slots
+insn-use-slots insn-temp-slots scalar-rep ;
 FROM: namespaces => set ;
 IN: compiler.cfg.representations.preferred
 
-GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: defs-vreg-reps ( insn -- reps )
 GENERIC: temp-vreg-reps ( insn -- reps )
 GENERIC: uses-vreg-reps ( insn -- reps )
 
-M: insn defs-vreg-rep drop f ;
+M: insn defs-vreg-reps drop { } ;
 M: insn temp-vreg-reps drop { } ;
 M: insn uses-vreg-reps drop { } ;
 
@@ -26,13 +27,6 @@ M: insn uses-vreg-reps drop { } ;
         [ [ drop ] swap suffix ]
     } case ;
 
-: define-defs-vreg-rep-method ( insn -- )
-    dup insn-def-slot dup [
-        [ \ defs-vreg-rep create-method ]
-        [ rep>> rep-getter-quot ]
-        bi* define
-    ] [ 2drop ] if ;
-
 : reps-getter-quot ( reps -- quot )
     dup [ rep>> { f scalar-rep } member-eq? not ] all? [
         [ rep>> ] map [ drop ] swap suffix
@@ -45,32 +39,54 @@ M: insn uses-vreg-reps drop { } ;
         } case
     ] if ;
 
-: define-uses-vreg-reps-method ( insn -- )
+: define-vreg-reps-method ( insn slots word -- )
-    dup insn-use-slots [ drop ] [
+    [ [ drop ] ] dip '[
-        [ \ uses-vreg-reps create-method ]
+        [ _ create-method ]
         [ reps-getter-quot ]
         bi* define
     ] if-empty ;
 
+: define-defs-vreg-reps-method ( insn -- )
+    dup insn-def-slots \ defs-vreg-reps define-vreg-reps-method ;
+
+: define-uses-vreg-reps-method ( insn -- )
+    dup insn-use-slots \ uses-vreg-reps define-vreg-reps-method ;
+
 : define-temp-vreg-reps-method ( insn -- )
-    dup insn-temp-slots [ drop ] [
+    dup insn-temp-slots \ temp-vreg-reps define-vreg-reps-method ;
-        [ \ temp-vreg-reps create-method ]
-        [ reps-getter-quot ]
-        bi* define
-    ] if-empty ;
 
 PRIVATE>
 
+M: alien-call-insn defs-vreg-reps
+    reg-outputs>> [ second ] map ;
+
+M: ##callback-inputs defs-vreg-reps
+    [ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ;
+
+M: ##callback-outputs defs-vreg-reps drop { } ;
+
+M: alien-call-insn uses-vreg-reps
+    [ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ;
+
+M: ##alien-indirect uses-vreg-reps
+    call-next-method int-rep prefix ;
+
+M: ##callback-inputs uses-vreg-reps
+    drop { } ;
+
+M: ##callback-outputs uses-vreg-reps
+    reg-inputs>> [ second ] map ;
+
 [
     insn-classes get
-    [ [ define-defs-vreg-rep-method ] each ]
+    [ special-vreg-insns diff [ define-defs-vreg-reps-method ] each ]
-    [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+    [ special-vreg-insns diff [ define-uses-vreg-reps-method ] each ]
     [ [ define-temp-vreg-reps-method ] each ]
     tri
 ] with-compilation-unit
 
 : each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
-    [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+    [ [ defs-vregs ] [ defs-vreg-reps ] bi ] dip 2each ; inline
 
 : each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
@@ -80,12 +96,3 @@ PRIVATE>
 
 : each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
-
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
-    '[
-        [ basic-block set ] [
-            [
-                _ each-rep
-            ] each-non-phi
-        ] bi
-    ] each-basic-block ; inline

basis/compiler/cfg/representations/representations-tests.factor

@@ -16,13 +16,13 @@ IN: compiler.cfg.representations
     } uses-vreg-reps
 ] unit-test
 
-[ double-rep ] [
+[ { double-rep } ] [
     T{ ##load-memory-imm
        { dst 5 }
        { base 3 }
        { offset 0 }
        { rep double-rep }
-    } defs-vreg-rep
+    } defs-vreg-reps
 ] unit-test
 
 H{ } clone representations set

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

@@ -44,10 +44,6 @@ V{
 
 V{
     T{ ##inc-d f 3 }
-    T{ ##load-reg-param f 0 RCX int-rep }
-    T{ ##load-reg-param f 1 RDX int-rep }
-    T{ ##load-reg-param f 2 R8 int-rep }
-    T{ ##begin-callback }
     T{ ##box f 4 3 "from_signed_4" int-rep
         T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
     }
@@ -58,11 +54,7 @@ V{
 [
     V{
         T{ ##inc-d f 3 }
-        T{ ##load-reg-param f 0 RCX int-rep }
-        T{ ##load-reg-param f 1 RDX int-rep }
-        T{ ##load-reg-param f 2 R8 int-rep }
         T{ ##save-context f 5 6 }
-        T{ ##begin-callback }
         T{ ##box f 4 3 "from_signed_4" int-rep
             T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
         }

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

@@ -20,7 +20,7 @@ GENERIC: modifies-context? ( insn -- ? )
 
 M: ##inc-d modifies-context? drop t ;
 M: ##inc-r modifies-context? drop t ;
-M: ##load-reg-param modifies-context? drop t ;
+M: ##callback-inputs modifies-context? drop t ;
 M: insn modifies-context? drop f ;
 
 : save-context-offset ( bb -- n )

basis/compiler/cfg/scheduling/scheduling-tests.factor

@@ -1,4 +1,5 @@
-USING: compiler.cfg.scheduling vocabs.loader namespaces tools.test ;
+USING: compiler.cfg.scheduling compiler.cfg.instructions
+vocabs.loader namespaces tools.test arrays kernel ;
 IN: compiler.cfg.scheduling.tests
 
 ! Recompile compiler.cfg.scheduling with extra tests,
@@ -9,3 +10,46 @@ t check-scheduling? [
     [ ] [ "compiler.cfg.scheduling" reload ] unit-test
     [ ] [ "compiler.cfg.dependence" reload ] unit-test
 ] with-variable
+
+[
+    { }
+    { }
+    { T{ ##test-branch } }
+] [
+    V{ T{ ##test-branch } }
+    split-3-ways
+    [ >array ] tri@
+] unit-test
+
+[
+    { T{ ##inc-d } T{ ##inc-r } T{ ##callback-inputs } }
+    { T{ ##add } T{ ##sub } T{ ##mul } }
+    { T{ ##test-branch } }
+] [
+    V{
+        T{ ##inc-d }
+        T{ ##inc-r }
+        T{ ##callback-inputs }
+        T{ ##add }
+        T{ ##sub }
+        T{ ##mul }
+        T{ ##test-branch }
+    }
+    split-3-ways
+    [ >array ] tri@
+] unit-test
+
+[
+    { }
+    { T{ ##add } T{ ##sub } T{ ##mul } }
+    { T{ ##dispatch } }
+] [
+    V{
+        T{ ##add }
+        T{ ##sub }
+        T{ ##mul }
+        T{ ##dispatch }
+    }
+    split-3-ways
+    [ >array ] tri@
+] unit-test

basis/compiler/cfg/scheduling/scheduling.factor

@@ -52,21 +52,34 @@ ERROR: bad-delete-at key assoc ;
         , (reorder)
     ] when* ;
 
-: cut-by ( seq quot -- before after )
+UNION: initial-insn ##phi ##inc-d ##inc-r ##callback-inputs ;
-    dupd find drop [ cut ] [ f ] if* ; inline
 
-UNION: initial-insn
+UNION: final-insn
-    ##phi ##inc-d ##inc-r ;
+##branch
+##dispatch
+conditional-branch-insn
+##epilogue ##return
+##callback-outputs ;
 
-: split-3-ways ( insns -- first middle last )
+: initial-insn-end ( insns -- n )
-    [ initial-insn? not ] cut-by unclip-last ;
+    [ initial-insn? not ] find drop 0 or ;
+
+: final-insn-start ( insns -- n )
+    [ final-insn? not ] find-last drop [ 1 + ] [ 0 ] if* ;
+
+:: split-3-ways ( insns -- first middle last )
+    insns initial-insn-end :> a
+    insns final-insn-start :> b
+    insns a head-slice
+    a b insns <slice>
+    insns b tail-slice ;
 
 : reorder ( insns -- insns' )
     split-3-ways [
         build-dependence-graph
         build-fan-in-trees
         [ (reorder) ] V{ } make reverse
-    ] dip suffix append ;
+    ] dip 3append ;
 
 ERROR: not-all-instructions-were-scheduled old-bb new-bb ;
 
@@ -78,16 +91,16 @@ f check-scheduling? set-global
     [ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and
     [ old-bb new-bb not-all-instructions-were-scheduled ] unless ;
 
-ERROR: definition-after-usage vreg old-bb new-bb ;
+ERROR: definition-after-usage vregs old-bb new-bb ;
 
 :: check-usages ( new-bb old-bb -- )
     HS{ } clone :> useds
     new-bb instructions>> split-3-ways drop nip
     [| insn |
         insn uses-vregs [ useds adjoin ] each
-        insn defs-vreg :> def-reg
+        insn defs-vregs :> defs-vregs
-        def-reg useds in?
+        defs-vregs useds intersects?
-        [ def-reg old-bb new-bb definition-after-usage ] when
+        [ defs-vregs old-bb new-bb definition-after-usage ] when
     ] each ;
 
 : check-scheduling ( new-bb old-bb -- )
@@ -124,7 +137,7 @@ ERROR: definition-after-usage vreg old-bb new-bb ;
 
 : might-spill? ( bb -- ? )
     [ live-in assoc-size ]
-    [ instructions>> [ defs-vreg ] count ] bi
+    [ instructions>> [ defs-vregs length ] map-sum ] bi
     + num-registers >= ;
 
 : schedule-instructions ( cfg -- cfg' )

basis/compiler/cfg/ssa/construction/construction.factor

@@ -32,11 +32,15 @@ SYMBOL: defs
 ! Set of vregs defined in more than one basic block
 SYMBOL: defs-multi
 
-: compute-insn-defs ( bb insn -- )
+GENERIC: compute-insn-defs ( bb insn -- )
-    defs-vreg dup [
+
+M: insn compute-insn-defs 2drop ;
+
+M: vreg-insn compute-insn-defs
+    defs-vregs [
         defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
         [ defs-multi get conjoin ] [ drop ] if
-    ] [ 2drop ] if ;
+    ] with each ;
 
 : compute-defs ( cfg -- )
     H{ } clone defs set

basis/compiler/cfg/ssa/cssa/cssa.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry sequences
+USING: accessors assocs kernel locals fry sequences sets
 cpu.architecture
 compiler.cfg.rpo
 compiler.cfg.def-use
@@ -18,7 +18,7 @@ IN: compiler.cfg.ssa.cssa
     ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
     ! need to insert a copy since in fact doing so will result
     ! in incorrect code.
-    [ instructions>> last defs-vreg ] dip eq? not ;
+    [ instructions>> last defs-vregs ] dip swap in? not ;
 
 :: insert-copy ( bb src rep -- bb dst )
     bb src insert-copy? [

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -47,7 +47,7 @@ SYMBOL: class-element-map
 SYMBOL: copies
 
 : value-of ( vreg -- value )
-    insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ;
+    dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ;
 
 : init-coalescing ( -- )
     defs get
@@ -85,9 +85,9 @@ M: insn prepare-insn drop ;
 M: vreg-insn prepare-insn
     [ temp-vregs [ leader-map get conjoin ] each ]
     [
-        [ defs-vreg ] [ uses-vregs ] bi
+        [ defs-vregs ] [ uses-vregs ] bi
-        2dup empty? not and [
+        2dup [ empty? not ] both? [
-            first
+            [ first ] bi@
             2dup [ rep-of reg-class-of ] bi@ eq?
             [ maybe-eliminate-copy-later ] [ 2drop ] if
         ] [ 2drop ] if

basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor

@@ -12,26 +12,26 @@ IN: compiler.cfg.ssa.interference.live-ranges
 
 SYMBOLS: local-def-indices local-kill-indices ;
 
-: record-def ( n insn -- )
+: record-defs ( n insn -- )
-    defs-vreg dup [ local-def-indices get set-at ] [ 2drop ] if ;
+    defs-vregs [ local-def-indices get set-at ] with each ;
 
 : record-uses ( n insn -- )
     ! Record live intervals so that all but the first input interfere
     ! with the output. This lets us coalesce the output with the
     ! first input.
-    dup uses-vregs dup empty? [ 3drop ] [
+    dup uses-vregs [ 2drop ] [
         swap def-is-use-insn?
         [ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless
         [ 1 + ] dip [ local-kill-indices get set-at ] with each
-    ] if ;
+    ] if-empty ;
 
 GENERIC: record-insn ( n insn -- )
 
 M: ##phi record-insn
-    record-def ;
+    record-defs ;
 
 M: vreg-insn record-insn
-    [ 2 * ] dip [ record-def ] [ record-uses ] 2bi ;
+    [ 2 * ] dip [ record-defs ] [ record-uses ] 2bi ;
 
 M: insn record-insn
     2drop ;

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

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes classes.algebra combinators fry
 generic.parser kernel math namespaces quotations sequences slots
-words make
+words make sets
 compiler.cfg.instructions
 compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph ;
@@ -49,7 +49,8 @@ GENERIC: >expr ( insn -- expr )
     [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
 
 insn-classes get
-[ pure-insn class<= ] filter
+[ foldable-insn class<= ] filter
+{ ##copy ##load-integer ##load-reference } diff
 [
     dup "insn-slots" word-prop input-values
     define->expr-method

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

@@ -36,9 +36,12 @@ GENERIC: process-instruction ( insn -- insn' )
     [ redundant-instruction ] [ useful-instruction ] ?if ;
 
 M: insn process-instruction
+    dup rewrite [ process-instruction ] [ ] ?if ;
+
+M: foldable-insn process-instruction
     dup rewrite
     [ process-instruction ]
-    [ dup defs-vreg [ check-redundancy ] when ] ?if ;
+    [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
 
 M: ##copy process-instruction
     dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;

basis/compiler/codegen/codegen.factor

@@ -91,8 +91,6 @@ M: ##dispatch generate-insn
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: ##stack-frame generate-insn drop ;
-
 M: ##prologue generate-insn
     drop
     cfg get stack-frame>>
@@ -287,21 +285,12 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul
 ! FFI
 CODEGEN: ##unbox %unbox
 CODEGEN: ##unbox-long-long %unbox-long-long
-CODEGEN: ##store-reg-param %store-reg-param
-CODEGEN: ##store-stack-param %store-stack-param
-CODEGEN: ##load-reg-param %load-reg-param
-CODEGEN: ##load-stack-param %load-stack-param
 CODEGEN: ##local-allot %local-allot
 CODEGEN: ##box %box
 CODEGEN: ##box-long-long %box-long-long
-CODEGEN: ##allot-byte-array %allot-byte-array
-CODEGEN: ##prepare-var-args %prepare-var-args
 CODEGEN: ##alien-invoke %alien-invoke
-CODEGEN: ##cleanup %cleanup
 CODEGEN: ##alien-indirect %alien-indirect
-CODEGEN: ##begin-callback %begin-callback
+CODEGEN: ##alien-assembly %alien-assembly
+CODEGEN: ##callback-inputs %callback-inputs
 CODEGEN: ##alien-callback %alien-callback
-CODEGEN: ##end-callback %end-callback
+CODEGEN: ##callback-outputs %callback-outputs
-
-M: ##alien-assembly generate-insn
-    [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;

basis/compiler/tests/alien.factor

@@ -776,10 +776,22 @@ mingw? [
 
 [ 3 ] [ blah ] unit-test
 
-: out-param-test ( -- b )
+: out-param-test-1 ( -- b )
-    { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
+    { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
 
-[ 12 ] [ out-param-test ] unit-test
+[ 12 ] [ out-param-test-1 ] unit-test
+
+: out-param-test-2 ( -- b )
+    { { int initial: 12 } } [ drop ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-2 ] unit-test
+
+: out-param-test-3 ( -- x y )
+    { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
+    with-out-parameters
+    [ x>> ] [ y>> ] bi ;
+
+[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
 
 : out-param-callback ( -- a )
     void { int pointer: int } cdecl
@@ -789,6 +801,6 @@ mingw? [
     { int } [
         swap void { int pointer: int } cdecl
         alien-indirect
-    ] [ ] with-out-parameters ;
+    ] with-out-parameters ;
 
 [ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test

basis/compiler/tests/optimizer.factor

@@ -454,7 +454,6 @@ STRUCT: BitmapData { Scan0 void* } ;
     [
         { BitmapData }
         [ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
-        [ clone ]
         with-out-parameters Scan0>>
     ] compile-call
 ] unit-test

basis/compiler/tests/simple.factor

@@ -1,7 +1,7 @@
 USING: compiler.test compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings alien
 arrays memory vocabs parser eval quotations compiler.errors
-definitions ;
+definitions generic.single ;
 IN: compiler.tests.simple
 
 ! Test empty word
@@ -249,3 +249,6 @@ M: quotation bad-effect-test call ; inline
 
 ! Don't want compiler error to stick around
 [ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
+
+! Make sure time bombs literalize
+[ [ \ + call ] compile-call ] [ no-method? ] must-fail-with

basis/compiler/tests/tuples.factor

@@ -8,3 +8,9 @@ TUPLE: color red green blue ;
 
 [ T{ color f f f f } ]
 [ [ color new ] compile-call ] unit-test
+
+SYMBOL: foo
+
+[ [ foo new ] compile-call ] must-fail
+
+[ [ foo boa ] compile-call ] must-fail

basis/core-foundation/strings/strings.factor

@@ -78,8 +78,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
     [ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
     4 * 1 + <byte-array> [
         dup length
-        { CFIndex } [ CFStringGetBytes drop ] [ ]
+        { CFIndex } [ CFStringGetBytes drop ] with-out-parameters
-        with-out-parameters
     ] keep
     swap head-slice utf8 decode ;
 

basis/core-text/core-text.factor

@@ -51,7 +51,7 @@ TUPLE: line < disposable line metrics image loc dim ;
 
 : typographic-bounds ( line -- width ascent descent leading )
     { CGFloat CGFloat CGFloat }
-    [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
+    [ CTLineGetTypographicBounds ] with-out-parameters ; inline
 
 : store-typographic-bounds ( metrics width ascent descent leading -- metrics )
     {

basis/cpu/architecture/architecture.factor

@@ -585,11 +585,7 @@ HOOK: struct-return-on-stack? cpu ( -- ? )
 ! can be passed to a C function, or returned from a callback
 HOOK: %unbox cpu ( dst src func rep -- )
 
-HOOK: %unbox-long-long cpu ( src out func -- )
+HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- )
-
-HOOK: %store-reg-param cpu ( src reg rep -- )
-
-HOOK: %store-stack-param cpu ( src n rep -- )
 
 HOOK: %local-allot cpu ( dst size align offset -- )
 
@@ -600,32 +596,20 @@ HOOK: %box cpu ( dst src func rep gc-map -- )
 
 HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
 
-HOOK: %allot-byte-array cpu ( dst size gc-map -- )
-
 HOOK: %save-context cpu ( temp1 temp2 -- )
 
-HOOK: %prepare-var-args cpu ( -- )
+HOOK: %c-invoke cpu ( symbols dll gc-map -- )
 
-M: object %prepare-var-args ;
+HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
 
-HOOK: %alien-invoke cpu ( function library gc-map -- )
+HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
 
-HOOK: %cleanup cpu ( n -- )
+HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
 
-M: object %cleanup ( n -- ) drop ;
+HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
-
-HOOK: %alien-indirect cpu ( src gc-map -- )
-
-HOOK: %load-reg-param cpu ( dst reg rep -- )
-
-HOOK: %load-stack-param cpu ( dst n rep -- )
-
-HOOK: %begin-callback cpu ( -- )
 
 HOOK: %alien-callback cpu ( quot -- )
 
-HOOK: %end-callback cpu ( -- )
+HOOK: %callback-outputs cpu ( reg-inputs -- )
 
 HOOK: stack-cleanup cpu ( stack-size return abi -- n )
-
-M: object stack-cleanup 3drop 0 ;

basis/cpu/ppc/ppc.factor

@@ -230,13 +230,13 @@ M: integer float-function-param* FMR ;
 
 M:: ppc %unary-float-function ( dst src func -- )
     0 src float-function-param
-    func f %alien-invoke
+    func f %c-invoke
     dst float-function-return ;
 
 M:: ppc %binary-float-function ( dst src1 src2 func -- )
     0 src1 float-function-param
     1 src2 float-function-param
-    func f %alien-invoke
+    func f %c-invoke
     dst float-function-return ;
 
 ! Internal format is always double-precision on PowerPC
@@ -513,7 +513,7 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
 M: ppc %call-gc ( gc-roots -- )
     3 swap gc-root-offsets %load-reference
     4 %load-vm-addr
-    "inline_gc" f %alien-invoke ;
+    "inline_gc" f %c-invoke ;
 
 M: ppc %prologue ( n -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
@@ -689,7 +689,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
 :: call-unbox-func ( src func -- )
     3 src load-param
     4 %load-vm-addr
-    func f %alien-invoke ;
+    func f %c-invoke ;
 
 M:: ppc %unbox ( src n rep func -- )
     src func call-unbox-func
@@ -708,12 +708,12 @@ M:: ppc %unbox-large-struct ( src n c-type -- )
     4 src load-param
     3 1 n local@ ADDI
     c-type heap-size 5 LI
-    "memcpy" "libc" load-library %alien-invoke ;
+    "memcpy" "libc" load-library %c-invoke ;
 
 M:: ppc %box ( dst n rep func -- )
     n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
     rep double-rep? 5 4 ? %load-vm-addr
-    func f %alien-invoke
+    func f %c-invoke
     3 dst store-param ;
 
 M:: ppc %box-long-long ( dst n func -- )
@@ -722,7 +722,7 @@ M:: ppc %box-long-long ( dst n func -- )
         4 1 n cell + local@ LWZ
     ] when
     5 %load-vm-addr
-    func f %alien-invoke
+    func f %c-invoke
     3 dst store-param ;
 
 : struct-return@ ( n -- n )
@@ -740,7 +740,7 @@ M:: ppc %box-large-struct ( dst n c-type -- )
     c-type heap-size 4 LI
     5 %load-vm-addr
     ! Call the function
-    "from_value_struct" f %alien-invoke
+    "from_value_struct" f %c-invoke
     3 dst store-param ;
 
 M:: ppc %restore-context ( temp1 temp2 -- )
@@ -754,7 +754,7 @@ M:: ppc %save-context ( temp1 temp2 -- )
     ds-reg temp1 "datastack" context-field-offset STW
     rs-reg temp1 "retainstack" context-field-offset STW ;
 
-M: ppc %alien-invoke ( symbol dll -- )
+M: ppc %c-invoke ( symbol dll -- )
     [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
 M: ppc %alien-indirect ( src -- )
@@ -773,7 +773,7 @@ M:: ppc %box-small-struct ( dst c-type -- )
     #! Box a <= 16-byte struct returned in r3:r4:r5:r6
     c-type heap-size 7 LI
     8 %load-vm-addr
-    "from_medium_struct" f %alien-invoke
+    "from_medium_struct" f %c-invoke
     3 dst store-param ;
 
 : %unbox-struct-1 ( -- )
@@ -802,7 +802,7 @@ M:: ppc %unbox-small-struct ( src c-type -- )
 
 M: ppc %begin-callback ( -- )
     3 %load-vm-addr
-    "begin_callback" f %alien-invoke ;
+    "begin_callback" f %c-invoke ;
 
 M: ppc %alien-callback ( quot -- )
     3 swap %load-reference
@@ -812,7 +812,7 @@ M: ppc %alien-callback ( quot -- )
 
 M: ppc %end-callback ( -- )
     3 %load-vm-addr
-    "end_callback" f %alien-invoke ;
+    "end_callback" f %c-invoke ;
 
 enable-float-functions
 

basis/cpu/x86/32/32.factor

@@ -96,6 +96,24 @@ M: x86.32 %prologue ( n -- )
 M: x86.32 %prepare-jump
     pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
 
+M: x86.32 %load-stack-param ( dst rep n -- )
+    next-stack@ swap pick register? [ %copy ] [
+        {
+            { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] }
+            { float-rep [ FLDS ?spill-slot FSTPS ] }
+            { double-rep [ FLDL ?spill-slot FSTPL ] }
+        } case
+    ] if ;
+
+M: x86.32 %store-stack-param ( src rep n -- )
+    stack@ swap pick register? [ [ swap ] dip %copy ] [
+        {
+            { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] }
+            { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] }
+            { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] }
+        } case
+    ] if ;
+
 :: load-float-return ( dst x87-insn rep -- )
     dst register? [
         ESP 4 SUB
@@ -106,8 +124,8 @@ M: x86.32 %prepare-jump
         dst ?spill-slot x87-insn execute
     ] if ; inline
 
-M: x86.32 %load-reg-param ( dst reg rep -- )
+M: x86.32 %load-reg-param ( vreg rep reg -- )
-    {
+    swap {
         { int-rep [ int-rep %copy ] }
         { float-rep [ drop \ FSTPS float-rep load-float-return ] }
         { double-rep [ drop \ FSTPL double-rep load-float-return ] }
@@ -123,8 +141,8 @@ M: x86.32 %load-reg-param ( dst reg rep -- )
         src ?spill-slot x87-insn execute
     ] if ; inline
 
-M: x86.32 %store-reg-param ( src reg rep -- )
+M: x86.32 %store-reg-param ( vreg rep reg -- )
-    {
+    swap {
         { int-rep [ swap int-rep %copy ] }
         { float-rep [ drop \ FLDS float-rep store-float-return ] }
         { double-rep [ drop \ FLDL double-rep store-float-return ] }
@@ -134,49 +152,39 @@ M: x86.32 %store-reg-param ( src reg rep -- )
     EAX src tagged-rep %copy
     4 save-vm-ptr
     0 stack@ EAX MOV
-    func f f %alien-invoke ;
+    func f f %c-invoke ;
 
 M:: x86.32 %unbox ( dst src func rep -- )
     src func call-unbox-func
     dst rep %load-return ;
 
-M:: x86.32 %unbox-long-long ( src out func -- )
+M:: x86.32 %unbox-long-long ( dst1 dst2 src func -- )
-    EAX src int-rep %copy
+    src int-rep 0 %store-stack-param
-    0 stack@ EAX MOV
+    4 save-vm-ptr
-    EAX out int-rep %copy
+    func f f %c-invoke
-    4 stack@ EAX MOV
+    dst1 EAX int-rep %copy
-    8 save-vm-ptr
+    dst2 EDX int-rep %copy ;
-    func f f %alien-invoke ;
 
 M:: x86.32 %box ( dst src func rep gc-map -- )
+    src rep 0 %store-stack-param
     rep rep-size save-vm-ptr
-    src rep %store-return
+    func f gc-map %c-invoke
-    0 stack@ rep %load-return
-    func f gc-map %alien-invoke
     dst EAX tagged-rep %copy ;
 
 M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
+    src1 int-rep 0 %store-stack-param
+    src2 int-rep 4 %store-stack-param
     8 save-vm-ptr
-    EAX src1 int-rep %copy
+    func f gc-map %c-invoke
-    0 stack@ EAX int-rep %copy
-    EAX src2 int-rep %copy
-    4 stack@ EAX int-rep %copy
-    func f gc-map %alien-invoke
     dst EAX tagged-rep %copy ;
 
-M:: x86.32 %allot-byte-array ( dst size gc-map -- )
+M: x86.32 %c-invoke
-    4 save-vm-ptr
-    0 stack@ size MOV
-    "allot_byte_array" f gc-map %alien-invoke
-    dst EAX tagged-rep %copy ;
-
-M: x86.32 %alien-invoke
     [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
 
 M: x86.32 %begin-callback ( -- )
     0 save-vm-ptr
     4 stack@ 0 MOV
-    "begin_callback" f f %alien-invoke ;
+    "begin_callback" f f %c-invoke ;
 
 M: x86.32 %alien-callback ( quot -- )
     [ EAX ] dip %load-reference
@@ -184,28 +192,17 @@ M: x86.32 %alien-callback ( quot -- )
 
 M: x86.32 %end-callback ( -- )
     0 save-vm-ptr
-    "end_callback" f f %alien-invoke ;
+    "end_callback" f f %c-invoke ;
-
-GENERIC: float-function-param ( n dst src -- )
-
-M:: spill-slot float-function-param ( n dst src -- )
-    ! We can clobber dst here since its going to contain the
-    ! final result
-    dst src double-rep %copy
-    dst n double-rep %store-stack-param ;
-
-M:: register float-function-param ( n dst src -- )
-    src n double-rep %store-stack-param ;
 
 M:: x86.32 %unary-float-function ( dst src func -- )
-    0 dst src float-function-param
+    src double-rep 0 %store-stack-param
-    func "libm" load-library f %alien-invoke
+    func "libm" load-library f %c-invoke
     dst double-rep %load-return ;
 
 M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
-    0 dst src1 float-function-param
+    src1 double-rep 0 %store-stack-param
-    8 dst src2 float-function-param
+    src2 double-rep 8 %store-stack-param
-    func "libm" load-library f %alien-invoke
+    func "libm" load-library f %c-invoke
     dst double-rep %load-return ;
 
 : funny-large-struct-return? ( return abi -- ? )

basis/cpu/x86/64/64.factor

@@ -81,38 +81,40 @@ M: x86.64 %mark-deck
     dup load-decks-offset
     [+] card-mark <byte> MOV ;
 
-M:: x86.64 %load-reg-param ( dst reg rep -- )
+M:: x86.64 %load-stack-param ( vreg rep n -- )
-    dst reg rep %copy ;
+    rep return-reg n next-stack@ rep %copy
+    vreg rep return-reg rep %copy ;
 
-M:: x86.64 %store-reg-param ( src reg rep -- )
+M:: x86.64 %store-stack-param ( vreg rep n -- )
-    reg src rep %copy ;
+    rep return-reg vreg rep %copy
+    n reserved-stack-space + stack@ rep return-reg rep %copy ;
+
+M:: x86.64 %load-reg-param ( vreg rep reg -- )
+    vreg reg rep %copy ;
+
+M:: x86.64 %store-reg-param ( vreg rep reg -- )
+    reg vreg rep %copy ;
 
 M:: x86.64 %unbox ( dst src func rep -- )
     param-reg-0 src tagged-rep %copy
     param-reg-1 %mov-vm-ptr
-    func f f %alien-invoke
+    func f f %c-invoke
     dst rep %load-return ;
 
 M:: x86.64 %box ( dst src func rep gc-map -- )
     0 rep reg-class-of cdecl param-regs at nth src rep %copy
     rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
-    func f gc-map %alien-invoke
+    func f gc-map %c-invoke
     dst int-rep %load-return ;
 
-M:: x86.64 %allot-byte-array ( dst size gc-map -- )
+M: x86.64 %c-invoke
-    param-reg-0 size MOV
-    param-reg-1 %mov-vm-ptr
-    "allot_byte_array" f gc-map %alien-invoke
-    dst int-rep %load-return ;
-
-M: x86.64 %alien-invoke
     [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
     gc-map-here ;
 
 M: x86.64 %begin-callback ( -- )
     param-reg-0 %mov-vm-ptr
     param-reg-1 0 MOV
-    "begin_callback" f f %alien-invoke ;
+    "begin_callback" f f %c-invoke ;
 
 M: x86.64 %alien-callback ( quot -- )
     [ param-reg-0 ] dip %load-reference
@@ -120,14 +122,14 @@ M: x86.64 %alien-callback ( quot -- )
 
 M: x86.64 %end-callback ( -- )
     param-reg-0 %mov-vm-ptr
-    "end_callback" f f %alien-invoke ;
+    "end_callback" f f %c-invoke ;
 
 : float-function-param ( i src -- )
     [ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
 
 M:: x86.64 %unary-float-function ( dst src func -- )
     0 src float-function-param
-    func "libm" load-library f %alien-invoke
+    func "libm" load-library f %c-invoke
     dst double-rep %load-return ;
 
 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
@@ -135,9 +137,13 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     ! src2 is always a spill slot
     0 src1 float-function-param
     1 src2 float-function-param
-    func "libm" load-library f %alien-invoke
+    func "libm" load-library f %c-invoke
     dst double-rep %load-return ;
 
+M: x86.64 stack-cleanup 3drop 0 ;
+
+M: x86.64 %cleanup 0 assert= ;
+
 M: x86.64 long-long-on-stack? f ;
 
 M: x86.64 float-on-stack? f ;

basis/cpu/x86/x86.factor

@@ -587,14 +587,8 @@ M:: x86 %spill ( src rep dst -- )
 M:: x86 %reload ( dst rep src -- )
     dst src rep %copy ;
 
-M:: x86 %store-stack-param ( src n rep -- )
+M:: x86 %local-allot ( dst size align offset -- )
-    n reserved-stack-space + stack@ src rep %copy ;
+    dst offset local-allot-offset special-offset stack@ LEA ;
-
-: %load-return ( dst rep -- )
-    [ reg-class-of return-regs at first ] keep %load-reg-param ;
-
-: %store-return ( dst rep -- )
-    [ reg-class-of return-regs at first ] keep %store-reg-param ;
 
 : next-stack@ ( n -- operand )
     #! nth parameter from the next stack frame. Used to box
@@ -603,14 +597,58 @@ M:: x86 %store-stack-param ( src n rep -- )
     #! set up by the caller.
     [ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
 
-M:: x86 %load-stack-param ( dst n rep -- )
+: return-reg ( rep -- reg )
-    dst n next-stack@ rep %copy ;
+    reg-class-of return-regs at first ;
 
-M:: x86 %local-allot ( dst size align offset -- )
+HOOK: %load-stack-param cpu ( vreg rep n -- )
-    dst offset local-allot-offset special-offset stack@ LEA ;
 
-M: x86 %alien-indirect ( src gc-map -- )
+HOOK: %store-stack-param cpu ( vreg rep n -- )
-    [ ?spill-slot CALL ] [ gc-map-here ] bi* ;
+
+HOOK: %load-reg-param cpu ( vreg rep reg -- )
+
+HOOK: %store-reg-param cpu ( vreg rep reg -- )
+
+: %load-return ( dst rep -- )
+    dup return-reg %load-reg-param ;
+
+: %store-return ( dst rep -- )
+    dup return-reg %store-reg-param ;
+
+HOOK: %prepare-var-args cpu ( -- )
+
+HOOK: %cleanup cpu ( n -- )
+
+:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- )
+    stack-inputs [ first3 %store-stack-param ] each
+    reg-inputs [ first3 %store-reg-param ] each
+    quot call
+    cleanup %cleanup
+    reg-outputs [ first3 %load-reg-param ] each ; inline
+
+M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
+    '[ _ _ _ %c-invoke ] emit-alien-insn ;
+
+M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
+    reg-inputs stack-inputs reg-outputs cleanup stack-size [
+        src ?spill-slot CALL
+        gc-map gc-map-here
+    ] emit-alien-insn ;
+
+M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
+    '[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
+
+HOOK: %begin-callback cpu ( -- )
+
+M: x86 %callback-inputs ( reg-outputs stack-outputs -- )
+    [ [ first3 %load-reg-param ] each ]
+    [ [ first3 %load-stack-param ] each ] bi*
+    %begin-callback ;
+
+HOOK: %end-callback cpu ( -- )
+
+M: x86 %callback-outputs ( reg-inputs -- )
+    %end-callback
+    [ first3 %store-reg-param ] each ;
 
 M: x86 %loop-entry 16 alignment [ NOP ] times ;
 
@@ -655,20 +693,20 @@ M: x86 immediate-bitwise? ( n -- ? )
 
 :: (%compare-float) ( dst src1 src2 cc temp compare -- )
     cc {
-        { cc<    [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVA  (%boolean) ] }
+        { cc<    [ src2 src1 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
-        { cc<=   [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+        { cc<=   [ src2 src1 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
-        { cc>    [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVA  (%boolean) ] }
+        { cc>    [ src1 src2 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
-        { cc>=   [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+        { cc>=   [ src1 src2 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
-        { cc=    [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+        { cc=    [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
-        { cc<>   [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+        { cc<>   [ src1 src2 compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
-        { cc<>=  [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+        { cc<>=  [ src1 src2 compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
-        { cc/<   [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+        { cc/<   [ src2 src1 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
-        { cc/<=  [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVB  (%boolean) ] }
+        { cc/<=  [ src2 src1 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
-        { cc/>   [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+        { cc/>   [ src1 src2 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
-        { cc/>=  [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVB  (%boolean) ] }
+        { cc/>=  [ src1 src2 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
-        { cc/=   [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+        { cc/=   [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
-        { cc/<>  [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVE  (%boolean) ] }
+        { cc/<>  [ src1 src2 compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
-        { cc/<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVP  (%boolean) ] }
+        { cc/<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
     } case ; inline
 
 : %jump-float= ( label -- )
@@ -684,20 +722,20 @@ M: x86 immediate-bitwise? ( n -- ? )
 
 :: (%compare-float-branch) ( label src1 src2 cc compare -- )
     cc {
-        { cc<    [ src2 src1 \ compare call( a b -- ) label JA  ] }
+        { cc<    [ src2 src1 compare call( a b -- ) label JA ] }
-        { cc<=   [ src2 src1 \ compare call( a b -- ) label JAE ] }
+        { cc<=   [ src2 src1 compare call( a b -- ) label JAE ] }
-        { cc>    [ src1 src2 \ compare call( a b -- ) label JA  ] }
+        { cc>    [ src1 src2 compare call( a b -- ) label JA ] }
-        { cc>=   [ src1 src2 \ compare call( a b -- ) label JAE ] }
+        { cc>=   [ src1 src2 compare call( a b -- ) label JAE ] }
-        { cc=    [ src1 src2 \ compare call( a b -- ) label %jump-float= ] }
+        { cc=    [ src1 src2 compare call( a b -- ) label %jump-float= ] }
-        { cc<>   [ src1 src2 \ compare call( a b -- ) label JNE ] }
+        { cc<>   [ src1 src2 compare call( a b -- ) label JNE ] }
-        { cc<>=  [ src1 src2 \ compare call( a b -- ) label JNP ] }
+        { cc<>=  [ src1 src2 compare call( a b -- ) label JNP ] }
-        { cc/<   [ src2 src1 \ compare call( a b -- ) label JBE ] }
+        { cc/<   [ src2 src1 compare call( a b -- ) label JBE ] }
-        { cc/<=  [ src2 src1 \ compare call( a b -- ) label JB  ] }
+        { cc/<=  [ src2 src1 compare call( a b -- ) label JB ] }
-        { cc/>   [ src1 src2 \ compare call( a b -- ) label JBE ] }
+        { cc/>   [ src1 src2 compare call( a b -- ) label JBE ] }
-        { cc/>=  [ src1 src2 \ compare call( a b -- ) label JB  ] }
+        { cc/>=  [ src1 src2 compare call( a b -- ) label JB ] }
-        { cc/=   [ src1 src2 \ compare call( a b -- ) label %jump-float/= ] }
+        { cc/=   [ src1 src2 compare call( a b -- ) label %jump-float/= ] }
-        { cc/<>  [ src1 src2 \ compare call( a b -- ) label JE  ] }
+        { cc/<>  [ src1 src2 compare call( a b -- ) label JE ] }
-        { cc/<>= [ src1 src2 \ compare call( a b -- ) label JP  ] }
+        { cc/<>= [ src1 src2 compare call( a b -- ) label JP ] }
     } case ;
 
 enable-min/max

basis/db/postgresql/lib/lib.factor

@@ -146,7 +146,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
                 ] [
                     &postgresql-free
                 ] if
-            ] [ ] with-out-parameters memory>byte-array
+            ] with-out-parameters memory>byte-array
         ] with-destructors 
     ] [
         drop pq-get-is-null nip [ f ] [ B{ } clone ] if

basis/db/sqlite/lib/lib.factor

@@ -27,7 +27,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
 
 : sqlite-open ( path -- db )
     normalize-path
-    { void* } [ sqlite3_open sqlite-check-result ] [ ]
+    { void* } [ sqlite3_open sqlite-check-result ]
     with-out-parameters ;
 
 : sqlite-close ( db -- )
@@ -36,8 +36,8 @@ ERROR: sqlite-sql-error < sql-error n string ;
 : sqlite-prepare ( db sql -- handle )
     utf8 encode dup length
     { void* void* }
-    [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
+    [ sqlite3_prepare_v2 sqlite-check-result ]
-    with-out-parameters ;
+    with-out-parameters drop ;
 
 : sqlite-bind-parameter-index ( handle name -- index )
     sqlite3_bind_parameter_index ;

basis/game/input/x11/x11.factor

@@ -89,7 +89,7 @@ M: x11-game-input-backend read-keyboard
 : query-pointer ( -- x y buttons )
     dpy get dup XDefaultRootWindow
     { int int int int int int int }
-    [ XQueryPointer drop ] [ ] with-out-parameters
+    [ XQueryPointer drop ] with-out-parameters
     [ 4 ndrop ] 3dip ;
 
 SYMBOL: mouse-reset?

basis/io/backend/windows/nt/nt.factor

@@ -56,7 +56,7 @@ M: winnt add-completion ( win32-handle -- )
     nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
     master-completion-port get-global
     { int void* pointer: OVERLAPPED }
-    [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
+    [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
     :> ( error? bytes key overlapped )
     bytes overlapped error? ;
 

basis/io/backend/windows/nt/privileges/privileges.factor

@@ -15,7 +15,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
 : (open-process-token) ( handle -- handle )
     flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
     { PHANDLE }
-    [ OpenProcessToken win32-error=0/f ] [ ]
+    [ OpenProcessToken win32-error=0/f ]
     with-out-parameters ;
 
 : open-process-token ( -- handle )

basis/io/files/info/windows/windows.factor

@@ -21,7 +21,7 @@ IN: io.files.info.windows
 TUPLE: windows-file-info < file-info attributes ;
 
 : get-compressed-file-size ( path -- n )
-    { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
+    { DWORD } [ GetCompressedFileSize ] with-out-parameters
     over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
 
 : set-windows-size-on-disk ( file-info path -- file-info )
@@ -100,12 +100,12 @@ CONSTANT: path-length $[ MAX_PATH 1 + ]
 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
     { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
     [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
-    [ [ utf16n alien>string ] 4dip utf16n alien>string ]
+    with-out-parameters
-    with-out-parameters ;
+    [ utf16n alien>string ] 4dip utf16n alien>string ;
 
 : file-system-space ( normalized-path -- available-space total-space free-space )
     { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
-    [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+    [ GetDiskFreeSpaceEx win32-error=0/f ]
     with-out-parameters ;
 
 : calculate-file-system-info ( file-system-info -- file-system-info' )
@@ -149,24 +149,21 @@ CONSTANT: names-buf-length 16384
 : volume>paths ( string -- array )
     { { ushort names-buf-length } uint }
     [ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
-    [ head utf16n alien>string { CHAR: \0 } split ]
+    with-out-parameters
-    with-out-parameters ;
+    head utf16n alien>string { CHAR: \0 } split ;
 
 : find-first-volume ( -- string handle )
     { { ushort path-length } }
     [ path-length FindFirstVolume dup win32-error=0/f ]
-    [ utf16n alien>string ]
+    with-out-parameters utf16n alien>string swap ;
-    with-out-parameters swap ;
 
 : find-next-volume ( handle -- string/f )
     { { ushort path-length } }
-    [ path-length FindNextVolume ]
+    [ path-length FindNextVolume ] with-out-parameters
-    [
     swap 0 = [
         GetLastError ERROR_NO_MORE_FILES =
         [ drop f ] [ win32-error-string throw ] if
-        ] [ utf16n alien>string ] if
+    ] [ utf16n alien>string ] if ;
-    ] with-out-parameters ;
 
 : find-volumes ( -- array )
     find-first-volume
@@ -189,8 +186,8 @@ M: winnt file-systems ( -- array )
         normalize-path open-read &dispose handle>>
         { FILETIME FILETIME FILETIME }
         [ GetFileTime win32-error=0/f ]
-        [ [ FILETIME>timestamp >local-time ] tri@ ]
         with-out-parameters
+        [ FILETIME>timestamp >local-time ] tri@
     ] with-destructors ;
 
 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )

basis/io/launcher/unix/unix.factor

@@ -95,7 +95,7 @@ TUPLE: signal n ;
     dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
 
 M: unix wait-for-processes ( -- ? )
-    { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
+    { int } [ -1 swap WNOHANG waitpid ] with-out-parameters
     swap dup 0 <= [
         2drop t
     ] [

basis/io/launcher/windows/windows.factor

@@ -159,7 +159,7 @@ M: windows kill-process* ( handle -- )
 
 : exit-code ( process -- n )
     hProcess>>
-    { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
+    { DWORD } [ GetExitCodeProcess ] with-out-parameters
     swap win32-error=0/f ;
 
 : process-exited ( process -- )

basis/io/sockets/windows/nt/nt.factor

@@ -26,7 +26,7 @@ M: winnt WSASocket-flags ( -- DWORD )
         WSAIoctl SOCKET_ERROR = [
             winsock-error-string throw
         ] when
-    ] [ ] with-out-parameters ;
+    ] with-out-parameters ;
 
 TUPLE: ConnectEx-args port
     s name namelen lpSendBuffer dwSendDataLength

basis/iokit/iokit.factor

@@ -131,11 +131,11 @@ TUPLE: mach-error error-code error-string ;
     dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
 
 : master-port ( -- port )
-    MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ;
+    MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] with-out-parameters ;
 
 : io-services-matching-dictionary ( nsdictionary -- iterator )
     master-port swap
-    { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
+    { uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ;
 
 : io-services-matching-service ( service -- iterator )
     IOServiceMatching io-services-matching-dictionary ;

basis/libc/libc.factor

@@ -91,6 +91,8 @@ PRIVATE>
 : free ( alien -- )
     >c-ptr [ delete-malloc ] [ (free) ] bi ;
 
+FUNCTION: void memset ( void* buf, int char, size_t size ) ;
+
 FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
 
 FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;

basis/math/combinatorics/combinatorics-docs.factor

@@ -103,3 +103,29 @@ HELP: >permutation
 { $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
 { $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
 
+HELP: all-subsets
+{ $values { "seq" sequence } { "subsets" sequence } }
+{ $description
+    "Returns all the subsets of a sequence."
+}
+{ $examples
+    { $example
+        "USING: math.combinatorics prettyprint ;"
+        "{ 1 2 3 } all-subsets ."
+        "{ { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } }"
+    }
+} ;
+
+HELP: selections
+{ $values { "seq" sequence } { "n" integer } { "selections" sequence } }
+{ $description
+    "Returns all the ways to take n (possibly the same) items from the "
+    "sequence of items."
+} 
+{ $examples
+    { $example
+        "USING: math.combinatorics prettyprint ;"
+        "{ 1 2 } 2 selections ."
+        "{ { 1 1 } { 1 2 } { 2 1 } { 2 2 } }"
+    }
+} ;

basis/math/combinatorics/combinatorics-tests.factor

@@ -70,3 +70,20 @@ IN: math.combinatorics.tests
 [ { { "a" "b" } { "a" "c" }
     { "a" "d" } { "b" "c" }
     { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
+
+[ { { } } ] [ { } all-subsets ] unit-test
+
+[ { { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } } ]
+[ { 1 2 3 } all-subsets ] unit-test
+
+[ { } ] [ { 1 2 } 0 selections ] unit-test
+
+[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test
+
+[ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ]
+[ { 1 2 } 2 selections ] unit-test
+
+[ { { 1 1 1 } { 1 1 2 } { 1 2 1 } { 1 2 2 }
+    { 2 1 1 } { 2 1 2 } { 2 2 1 } { 2 2 2 } } ]
+[ { 1 2 } 3 selections ] unit-test
+

basis/math/combinatorics/combinatorics.factor

@@ -1,7 +1,8 @@
-! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson.
 ! 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 ;
+    math.ranges namespaces sequences sorting make sequences.deep arrays
+    combinators ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -126,3 +127,23 @@ PRIVATE>
 
 : reduce-combinations ( seq k identity quot -- result )
     [ -rot ] dip each-combination ; inline
+
+: all-subsets ( seq -- subsets )
+    dup length [0,b] [
+        [ dupd all-combinations [ , ] each ] each
+    ] { } make nip ;
+
+: (selections) ( seq n -- selections )
+    dupd [ dup 1 > ] [
+        swap pick cartesian-product [
+            [ [ dup length 1 > [ flatten ] when , ] each ] each
+        ] { } make swap 1 -
+    ] while drop nip ;
+
+: selections ( seq n -- selections )
+    {
+        { 0 [ drop { } ] }
+        { 1 [ 1array ] }
+        [ (selections) ]
+    } case ;
+

basis/math/vectors/simd/simd-tests.factor

@@ -684,7 +684,7 @@ USE: alien
     { c:int float-4 } [
         [ 123 swap 0 c:int c:set-alien-value ]
         [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
-    ] [ ] with-out-parameters ;
+    ] with-out-parameters ;
 
 [ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
 
@@ -696,7 +696,7 @@ USE: alien
     { c:int } [
         123 swap 0 c:int c:set-alien-value
         >float (simd-stack-spill-test) float-4-with swap cos v*n
-    ] [ ] with-out-parameters ;
+    ] with-out-parameters ;
 
 [ ] [
     1.047197551196598 simd-stack-spill-test

basis/opengl/framebuffers/framebuffers.factor

@@ -51,4 +51,4 @@ IN: opengl.framebuffers
 
 : framebuffer-attachment ( attachment -- id )
     GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
-    { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
+    { uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ;

basis/opengl/opengl.factor

@@ -139,7 +139,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
     swap glPushAttrib call glPopAttrib ; inline
 
 : (gen-gl-object) ( quot -- id )
-    [ 1 { uint } ] dip [ ] with-out-parameters ; inline
+    [ 1 { uint } ] dip with-out-parameters ; inline
 
 : (delete-gl-object) ( id quot -- )
     [ 1 swap <uint> ] dip call ; inline

basis/opengl/shaders/shaders.factor

@@ -20,7 +20,7 @@ IN: opengl.shaders
     dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
 
 : gl-shader-get-int ( shader enum -- value )
-    { int } [ glGetShaderiv ] [ ] with-out-parameters ;
+    { int } [ glGetShaderiv ] with-out-parameters ;
 
 : gl-shader-ok? ( shader -- ? )
     GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
@@ -79,7 +79,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
     dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
 
 : gl-program-get-int ( program enum -- value )
-    { int } [ glGetProgramiv ] [ ] with-out-parameters ;
+    { int } [ glGetProgramiv ] with-out-parameters ;
 
 : gl-program-ok? ( program -- ? )
     GL_LINK_STATUS gl-program-get-int c-bool> ;

basis/opengl/textures/textures.factor

@@ -415,7 +415,7 @@ PRIVATE>
     [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
 
 : get-texture-float ( target level enum -- value )
-    { float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline
+    { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
 
 : get-texture-int ( target level enum -- value )
-    { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
+    { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline

basis/pango/cairo/cairo.factor

@@ -137,7 +137,7 @@ SYMBOL: dpi
 : line-offset>x ( layout n -- x )
     #! n is an index into the UTF8 encoding of the text
     [ drop first-line ] [ swap string>> >utf8-index ] 2bi
-    0 { int } [ pango_layout_line_index_to_x ] [ ] with-out-parameters
+    0 { int } [ pango_layout_line_index_to_x ] with-out-parameters
     pango>float ;
 
 : x>line-offset ( layout x -- n )
@@ -146,7 +146,7 @@ SYMBOL: dpi
         [ first-line ] dip
         float>pango
         { int int }
-        [ pango_layout_line_x_to_index drop ] [ ] with-out-parameters
+        [ pango_layout_line_x_to_index drop ] with-out-parameters
         swap
     ] [ drop string>> ] 2bi utf8-index> + ;
 

basis/random/windows/windows.factor

@@ -23,7 +23,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
         type
         flags
         CryptAcquireContextW
-    ] [ ] with-out-parameters ;
+    ] with-out-parameters ;
 
 : acquire-crypto-context ( provider type -- handle )
     CRYPT_MACHINE_KEYSET

basis/stack-checker/backend/backend.factor

@@ -110,13 +110,11 @@ M: object apply-object push-literal ;
         infer-quot-here
     ] dip recursive-state set ;
 
-: time-bomb ( error -- )
+: time-bomb-quot ( obj generic -- quot )
-    '[ _ throw ] infer-quot-here ;
+    [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
 
-ERROR: bad-call obj ;
+: time-bomb ( obj generic -- )
-
+    time-bomb-quot infer-quot-here ;
-M: bad-call summary
-    drop "call must be given a callable" ;
 
 : infer-literal-quot ( literal -- )
     dup recursive-quotation? [
@@ -127,7 +125,7 @@ M: bad-call summary
             [ [ recursion>> ] keep add-local-quotation ]
             bi infer-quot
         ] [
-            value>> \ bad-call boa time-bomb
+            value>> \ call time-bomb
         ] if
     ] if ;
 

basis/stack-checker/known-words/known-words.factor

@@ -156,17 +156,12 @@ M: object infer-call* \ call bad-macro-input ;
 
 \ compose [ infer-compose ] "special" set-word-prop
 
-ERROR: bad-executable obj ;
-
-M: bad-executable summary
-    drop "execute must be given a word" ;
-
 : infer-execute ( -- )
     pop-literal nip
     dup word? [
         apply-object
     ] [
-        \ bad-executable boa time-bomb
+        \ execute time-bomb
     ] if ;
 
 \ execute [ infer-execute ] "special" set-word-prop

basis/stack-checker/transforms/transforms.factor

@@ -145,7 +145,9 @@ IN: stack-checker.transforms
         [ depends-on-tuple-layout ]
         [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
         '[ @ _ <tuple-boa> ]
-    ] [ drop f ] if
+    ] [
+        \ boa time-bomb
+    ] if
 ] 1 define-transform
 
 \ boa t "no-compile" set-word-prop

basis/tools/test/test-docs.factor

@@ -53,7 +53,7 @@ $nl
 ABOUT: "tools.test"
 
 HELP: unit-test
-{ $syntax "[ output ] [ input ] unit-test" }
+{ $syntax "{ output } [ input ] unit-test" }
 { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
 { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
 

basis/ui/backend/cocoa/cocoa.factor

@@ -57,7 +57,7 @@ M: cocoa-ui-backend (pixel-format-attribute)
     [ drop f ]
     [
         first
-        { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
+        { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ]
         with-out-parameters
     ] if-empty ;
 

basis/ui/backend/windows/windows.factor

@@ -60,14 +60,14 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
 
 : arb-make-pixel-format ( world attributes -- pf )
     [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
-    [ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ;
+    [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
 
 : arb-pixel-format-attribute ( pixel-format attribute -- value )
     >WGL_ARB
     [ drop f ] [
         [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
         first <int> { int }
-        [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
+        [ wglGetPixelFormatAttribivARB win32-error=0/f ]
         with-out-parameters
     ] if-empty ;
 

basis/ui/backend/x11/x11.factor

@@ -39,11 +39,11 @@ SINGLETON: x11-ui-backend
         XGetWindowProperty
         Success assert=
     ]
+    with-out-parameters
     [| type format n-atoms bytes-after atoms |
         atoms n-atoms <direct-ulong-array> >array
         atoms XFree
-    ]
+    ] call ;
-    with-out-parameters ;
 
 : net-wm-hint-supported? ( atom -- ? )
     supported-net-wm-hints member? ;
@@ -93,7 +93,7 @@ M: x11-ui-backend (pixel-format-attribute)
     [ handle>> ] [ >glx-visual ] bi*
     [ 2drop f ] [
         first
-        { int } [ glXGetConfig drop ] [ ] with-out-parameters
+        { int } [ glXGetConfig drop ] with-out-parameters
     ] if-empty ;
 
 CONSTANT: modifiers

basis/ui/gadgets/worlds/worlds.factor

@@ -129,6 +129,7 @@ M: world request-focus-on ( child gadget -- )
     [ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
 
 GENERIC# apply-world-attributes 1 ( world attributes -- world )
+
 M: world apply-world-attributes
     {
         [ title>> >>title ]
@@ -166,15 +167,11 @@ flush-layout-cache-hook [ [ ] ] initialize
 
 GENERIC: begin-world ( world -- )
 GENERIC: end-world ( world -- )
-
 GENERIC: resize-world ( world -- )
 
-M: world begin-world
+M: world begin-world drop ;
-    drop ;
+M: world end-world drop ;
-M: world end-world
+M: world resize-world drop ;
-    drop ;
-M: world resize-world
-    drop ;
 
 M: world dim<<
     [ call-next-method ]

basis/ui/ui.factor

@@ -81,6 +81,9 @@ M: world graft*
         [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
     ] bi ;
 
+: dispose-window-resources ( world -- )
+    [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
+
 M: world ungraft*
     {
         [ set-gl-context ]
@@ -89,9 +92,9 @@ M: world ungraft*
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
         [ end-world ]
-        [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
+        [ dispose-window-resources ]
-        [ [ (close-window) f ] change-handle drop ]
         [ unfocus-world ]
+        [ [ (close-window) f ] change-handle drop ]
         [ promise>> t swap fulfill ]
     } cleave ;
 

basis/windows/dwmapi/dwmapi.factor

@@ -34,5 +34,5 @@ CONSTANT: WM_DWMCOMPOSITIONCHANGED HEX: 31E
 
 : composition-enabled? ( -- ? )
     windows-major 6 >=
-    [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
+    [ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ]
     [ f ] if ;

basis/windows/offscreen/offscreen.factor

@@ -27,7 +27,7 @@ IN: windows.offscreen
     [ nip ]
     [
         swap (bitmap-info) DIB_RGB_COLORS { void* }
-        [ f 0 CreateDIBSection ] [ ] with-out-parameters
+        [ f 0 CreateDIBSection ] with-out-parameters
     ] 2bi
     [ [ SelectObject drop ] keep ] dip ;
 

basis/windows/uniscribe/uniscribe.factor

@@ -20,12 +20,12 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
         swap ! icp
         FALSE ! fTrailing
     ] if
-    { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
+    { int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ;
 
 : x>line-offset ( x script-string -- n trailing )
     ssa>> ! ssa
     swap ! iX
-    { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
+    { int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ;
 
 <PRIVATE
 

extra/gdbm/ffi/ffi.factor

@@ -4,10 +4,10 @@ USING: alien alien.c-types alien.libraries alien.syntax classes.struct
 combinators system ;
 IN: gdbm.ffi
 
-<< "libgdbm" os {
+<< "libgdbm" {
-    { [ unix?   ] [ "libgdbm.so"    ] }
+    { [ os macosx? ] [ "libgdbm.dylib" ] }
-    { [ winnt?  ] [ "gdbm.dll"      ] }
+    { [ os unix?   ] [ "libgdbm.so"    ] }
-    { [ macosx? ] [ "libgdbm.dylib" ] }
+    { [ os winnt?  ] [ "gdbm.dll"      ] }
 } cond cdecl add-library >>
 
 LIBRARY: libgdbm

vm/byte_arrays.cpp

@@ -10,11 +10,6 @@ byte_array *factor_vm::allot_byte_array(cell size)
 	return array;
 }
 
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
-{
-	return tag<byte_array>(parent->allot_byte_array(size));
-}
-
 void factor_vm::primitive_byte_array()
 {
 	cell size = unbox_array_size();

vm/byte_arrays.hpp

@@ -21,6 +21,4 @@ template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value
 	return data;
 }
 
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
-
 }

vm/math.cpp

@@ -491,9 +491,9 @@ s64 factor_vm::to_signed_8(cell obj)
 	}
 }
 
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent)
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
 {
-	*out = parent->to_signed_8(obj);
+	return parent->to_signed_8(obj);
 }
 
 cell factor_vm::from_unsigned_8(u64 n)
@@ -524,9 +524,9 @@ u64 factor_vm::to_unsigned_8(cell obj)
 	}
 }
 
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent)
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
 {
-	*out = parent->to_unsigned_8(obj);
+	return parent->to_unsigned_8(obj);
 }
  
 VM_C_API cell from_float(float flo, factor_vm *parent)

vm/math.hpp

@@ -90,8 +90,8 @@ VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm);
 VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
 VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
 
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent);
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent);
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent);
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent);
 
 VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
 VM_C_API cell to_cell(cell tagged, factor_vm *vm);