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

basis/alien/arrays/arrays.factor

@@ -22,8 +22,6 @@ M: array c-type-align first c-type-align ;
 
 M: array c-type-align-first first c-type-align-first ;
 
-M: array c-type-stack-align? drop f ;
-
 M: array unbox-parameter drop void* unbox-parameter ;
 
 M: array unbox-return drop void* unbox-return ;
@@ -34,6 +32,8 @@ M: array box-return drop void* box-return ;
 
 M: array stack-size drop void* stack-size ;
 
+M: array flatten-c-type drop { int-rep } ;
+
 PREDICATE: string-type < pair
     first2 [ c-string = ] [ word? ] bi* and ;
 
@@ -52,9 +52,6 @@ M: string-type c-type-align
 M: string-type c-type-align-first
     drop void* c-type-align-first ;
 
-M: string-type c-type-stack-align?
-    drop void* c-type-stack-align? ;
-
 M: string-type unbox-parameter
     drop void* unbox-parameter ;
 
@@ -73,11 +70,8 @@ M: string-type stack-size
 M: string-type c-type-rep
     drop int-rep ;
 
-M: string-type c-type-boxer
+M: string-type flatten-c-type
-    drop void* c-type-boxer ;
+    drop { int-rep } ;
-
-M: string-type c-type-unboxer
-    drop void* c-type-unboxer ;
 
 M: string-type c-type-boxer-quot
     second dup binary =

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays arrays assocs delegate kernel kernel.private math
 math.order math.parser namespaces make parser sequences strings
@@ -17,7 +17,8 @@ SYMBOLS:
     long ulong
     longlong ulonglong
     float double
-    void* bool ;
+    void* bool
+    (stack-value) ;
 
 SINGLETON: void
 
@@ -38,8 +39,7 @@ TUPLE: abstract-c-type
 TUPLE: c-type < abstract-c-type
 boxer
 unboxer
-{ rep initial: int-rep }
+{ rep initial: int-rep } ;
-stack-align? ;
 
 : <c-type> ( -- c-type )
     \ c-type new ; inline
@@ -83,18 +83,10 @@ GENERIC: c-type-boxed-class ( name -- class )
 
 M: abstract-c-type c-type-boxed-class boxed-class>> ;
 
-GENERIC: c-type-boxer ( name -- boxer )
-
-M: c-type c-type-boxer boxer>> ;
-
 GENERIC: c-type-boxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
-GENERIC: c-type-unboxer ( name -- boxer )
-
-M: c-type c-type-unboxer unboxer>> ;
-
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
@@ -119,17 +111,11 @@ GENERIC: c-type-align-first ( name -- n )
 
 M: abstract-c-type c-type-align-first align-first>> ;
 
-GENERIC: c-type-stack-align? ( name -- ? )
-
-M: c-type c-type-stack-align? stack-align?>> ;
-
 : c-type-box ( n c-type -- )
-    [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
+    [ rep>> ] [ boxer>> ] bi %box ;
-    %box ;
 
 : c-type-unbox ( n c-type -- )
-    [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
+    [ rep>> ] [ unboxer>> ] bi %unbox ;
-    %unbox ;
 
 GENERIC: box-parameter ( n c-type -- )
 
@@ -157,24 +143,26 @@ GENERIC: stack-size ( name -- size )
 
 M: c-type stack-size size>> cell align ;
 
-: >c-bool ( ? -- int ) 1 0 ? ; inline
+: (flatten-c-type) ( type rep -- seq )
+    [ stack-size cell /i ] dip <repetition> ; inline
 
-: c-bool> ( int -- ? ) 0 = not ; inline
+GENERIC: flatten-c-type ( type -- reps )
+
+M: c-type flatten-c-type rep>> 1array ;
+M: c-type-name flatten-c-type c-type flatten-c-type ;
+
+: flatten-c-types ( types -- reps )
+    [ flatten-c-type ] map concat ;
 
 MIXIN: value-type
 
 : c-getter ( name -- quot )
-    c-type-getter [
+    [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
-        [ "Cannot read struct fields with this type" throw ]
-    ] unless* ;
-
-: c-type-getter-boxer ( name -- quot )
-    [ c-getter ] [ c-type-boxer-quot ] bi append ;
 
 : c-setter ( name -- quot )
-    c-type-setter [
+    [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
-        [ "Cannot write struct fields with this type" throw ]
+    [ c-type-setter ]
-    ] unless* ;
+    bi append ;
 
 : array-accessor ( c-type quot -- def )
     [
@@ -184,22 +172,20 @@ MIXIN: value-type
 PROTOCOL: c-type-protocol 
     c-type-class
     c-type-boxed-class
-    c-type-boxer
     c-type-boxer-quot
-    c-type-unboxer
     c-type-unboxer-quot
     c-type-rep
     c-type-getter
     c-type-setter
     c-type-align
     c-type-align-first
-    c-type-stack-align?
     box-parameter
     box-return
     unbox-parameter
     unbox-return
     heap-size
-    stack-size ;
+    stack-size
+    flatten-c-type ;
 
 CONSULT: c-type-protocol c-type-name
     c-type ;
@@ -219,17 +205,20 @@ TUPLE: long-long-type < c-type ;
     long-long-type new ;
 
 M: long-long-type unbox-parameter ( n c-type -- )
-    c-type-unboxer %unbox-long-long ;
+    unboxer>> %unbox-long-long ;
 
 M: long-long-type unbox-return ( c-type -- )
     f swap unbox-parameter ;
 
 M: long-long-type box-parameter ( n c-type -- )
-    c-type-boxer %box-long-long ;
+    boxer>> %box-long-long ;
 
 M: long-long-type box-return ( c-type -- )
     f swap box-parameter ;
 
+M: long-long-type flatten-c-type
+    int-rep (flatten-c-type) ;
+
 : define-deref ( c-type -- )
     [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
     (( c-ptr -- value )) define-inline ;
@@ -264,6 +253,10 @@ CONSTANT: primitive-types
 : (pointer-c-type) ( void* type -- void*' )
     [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ;
 
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
 <PRIVATE
 
 : resolve-pointer-typedef ( type -- base-type )
@@ -295,7 +288,7 @@ M: pointer c-type
         c-ptr >>class
         c-ptr >>boxed-class
         [ alien-cell ] >>getter
-        [ [ >c-ptr ] 2dip set-alien-cell ] >>setter
+        [ set-alien-cell ] >>setter
         bootstrap-cell >>size
         bootstrap-cell >>align
         bootstrap-cell >>align-first
@@ -304,30 +297,6 @@ M: pointer c-type
         "alien_offset" >>unboxer
     \ void* define-primitive-type
 
-    <c-type>
-        integer >>class
-        integer >>boxed-class
-        [ alien-signed-4 ] >>getter
-        [ set-alien-signed-4 ] >>setter
-        4 >>size
-        4 >>align
-        4 >>align-first
-        "from_signed_4" >>boxer
-        "to_fixnum" >>unboxer
-    \ int define-primitive-type
-
-    <c-type>
-        integer >>class
-        integer >>boxed-class
-        [ alien-unsigned-4 ] >>getter
-        [ set-alien-unsigned-4 ] >>setter
-        4 >>size
-        4 >>align
-        4 >>align-first
-        "from_unsigned_4" >>boxer
-        "to_cell" >>unboxer
-    \ uint define-primitive-type
-
     <c-type>
         fixnum >>class
         fixnum >>boxed-class
@@ -338,6 +307,7 @@ M: pointer c-type
         2 >>align-first
         "from_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ short define-primitive-type
 
     <c-type>
@@ -350,6 +320,7 @@ M: pointer c-type
         2 >>align-first
         "from_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ ushort define-primitive-type
 
     <c-type>
@@ -362,6 +333,7 @@ M: pointer c-type
         1 >>align-first
         "from_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ char define-primitive-type
 
     <c-type>
@@ -374,34 +346,14 @@ M: pointer c-type
         1 >>align-first
         "from_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        [ >fixnum ] >>unboxer-quot
     \ uchar define-primitive-type
 
-    cpu ppc? [
-        <c-type>
-            [ alien-unsigned-4 c-bool> ] >>getter
-            [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
-            4 >>size
-            4 >>align
-            4 >>align-first
-            "from_boolean" >>boxer
-            "to_boolean" >>unboxer
-    ] [
-        <c-type>
-            [ alien-unsigned-1 c-bool> ] >>getter
-            [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
-            1 >>size
-            1 >>align
-            1 >>align-first
-            "from_boolean" >>boxer
-            "to_boolean" >>unboxer
-    ] if
-    \ bool define-primitive-type
-
     <c-type>
         math:float >>class
         math:float >>boxed-class
         [ alien-float ] >>getter
-        [ [ >float ] 2dip set-alien-float ] >>setter
+        [ set-alien-float ] >>setter
         4 >>size
         4 >>align
         4 >>align-first
@@ -415,7 +367,7 @@ M: pointer c-type
         math:float >>class
         math:float >>boxed-class
         [ alien-double ] >>getter
-        [ [ >float ] 2dip set-alien-double ] >>setter
+        [ set-alien-double ] >>setter
         8 >>size
         8-byte-alignment
         "from_double" >>boxer
@@ -425,14 +377,40 @@ M: pointer c-type
     \ double define-primitive-type
 
     cell 8 = [
+        <c-type>
+            fixnum >>class
+            fixnum >>boxed-class
+            [ alien-signed-4 ] >>getter
+            [ set-alien-signed-4 ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_signed_4" >>boxer
+            "to_fixnum" >>unboxer
+            [ >fixnum ] >>unboxer-quot
+        \ int define-primitive-type
+    
+        <c-type>
+            fixnum >>class
+            fixnum >>boxed-class
+            [ alien-unsigned-4 ] >>getter
+            [ set-alien-unsigned-4 ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_unsigned_4" >>boxer
+            "to_cell" >>unboxer
+            [ >fixnum ] >>unboxer-quot
+        \ uint define-primitive-type
+
         <c-type>
             integer >>class
             integer >>boxed-class
             [ alien-signed-cell ] >>getter
             [ set-alien-signed-cell ] >>setter
-            bootstrap-cell >>size
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            8 >>align-first
             "from_signed_cell" >>boxer
             "to_fixnum" >>unboxer
         \ longlong define-primitive-type
@@ -442,9 +420,9 @@ M: pointer c-type
             integer >>boxed-class
             [ alien-unsigned-cell ] >>getter
             [ set-alien-unsigned-cell ] >>setter
-            bootstrap-cell >>size
+            8 >>size
-            bootstrap-cell >>align
+            8 >>align
-            bootstrap-cell >>align-first
+            8 >>align-first
             "from_unsigned_cell" >>boxer
             "to_cell" >>unboxer
         \ ulonglong define-primitive-type
@@ -463,6 +441,30 @@ M: pointer c-type
         \ ulonglong c-type \ uintptr_t typedef
         \ ulonglong c-type \ size_t typedef
     ] [
+        <c-type>
+            integer >>class
+            integer >>boxed-class
+            [ alien-signed-cell ] >>getter
+            [ set-alien-signed-cell ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_signed_cell" >>boxer
+            "to_fixnum" >>unboxer
+        \ int define-primitive-type
+    
+        <c-type>
+            integer >>class
+            integer >>boxed-class
+            [ alien-unsigned-cell ] >>getter
+            [ set-alien-unsigned-cell ] >>setter
+            4 >>size
+            4 >>align
+            4 >>align-first
+            "from_unsigned_cell" >>boxer
+            "to_cell" >>unboxer
+        \ uint define-primitive-type
+
         <long-long-type>
             integer >>class
             integer >>boxed-class
@@ -495,6 +497,15 @@ M: pointer c-type
         \ uint c-type \ size_t typedef
     ] if
 
+    cpu ppc? \ uint \ uchar ? c-type clone
+        [ >c-bool ] >>unboxer-quot
+        [ c-bool> ] >>boxer-quot
+        object >>boxed-class
+    \ bool define-primitive-type
+
+    \ void* c-type clone stack-params >>rep
+    \ (stack-value) define-primitive-type
+
 ] with-compilation-unit
 
 M: char-16-rep rep-component-type drop char ;

basis/alien/data/data.factor

@@ -68,8 +68,7 @@ M: value-type c-type-getter
     drop [ swap <displaced-alien> ] ;
 
 M: value-type c-type-setter ( type -- quot )
-    [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
+    [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
-    '[ @ swap @ _ memcpy ] ;
 
 M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;

basis/alien/parser/parser.factor

@@ -169,7 +169,7 @@ PREDICATE: alien-callback-type-word < typedef-word
 
 : global-quot ( type word -- quot )
     name>> current-library get '[ _ _ address-of 0 ]
-    swap c-type-getter-boxer append ;
+    swap c-getter append ;
 
 : define-global ( type word -- )
     [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

basis/bootstrap/compiler/timing/timing.factor

@@ -1,12 +1,10 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel make sequences tools.annotations tools.crossref ;
 QUALIFIED: compiler.cfg.builder
 QUALIFIED: compiler.cfg.linear-scan
-QUALIFIED: compiler.cfg.mr
 QUALIFIED: compiler.cfg.optimizer
-QUALIFIED: compiler.cfg.stacks.finalize
+QUALIFIED: compiler.cfg.finalization
-QUALIFIED: compiler.cfg.stacks.global
 QUALIFIED: compiler.codegen
 QUALIFIED: compiler.tree.builder
 QUALIFIED: compiler.tree.optimizer
@@ -19,7 +17,7 @@ IN: bootstrap.compiler.timing
 
 : low-level-passes ( -- seq ) \ compiler.cfg.optimizer:optimize-cfg passes ;
 
-: machine-passes ( -- seq ) \ compiler.cfg.mr:build-mr passes ;
+: machine-passes ( -- seq ) \ compiler.cfg.finalization:finalize-cfg passes ;
 
 : linear-scan-passes ( -- seq ) \ compiler.cfg.linear-scan:(linear-scan) passes ;
 
@@ -29,11 +27,9 @@ IN: bootstrap.compiler.timing
         \ compiler.tree.optimizer:optimize-tree ,
         high-level-passes %
         \ compiler.cfg.builder:build-cfg ,
-        \ compiler.cfg.stacks.global:compute-global-sets ,
-        \ compiler.cfg.stacks.finalize:finalize-stack-shuffling ,
         \ compiler.cfg.optimizer:optimize-cfg ,
         low-level-passes %
-        \ compiler.cfg.mr:build-mr ,
+        \ compiler.cfg.finalization:finalize-cfg ,
         machine-passes %
         linear-scan-passes %
         \ compiler.codegen:generate ,

basis/classes/struct/struct-tests.factor

@@ -211,7 +211,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { name "y" }
         { offset 4 }
         { initial 123 }
-        { class integer }
+        { class $[ cell 4 = integer fixnum ? ] }
         { type int }
     }
     T{ struct-slot-spec
@@ -235,7 +235,7 @@ UNION-STRUCT: struct-test-float-and-bits
         { name "bits" }
         { offset 0 }
         { type uint }
-        { class integer }
+        { class $[ cell 4 = integer fixnum ? ] }
         { initial 0 }
     }
 } ] [ struct-test-float-and-bits c-type fields>> ] unit-test

basis/classes/struct/struct.factor

@@ -9,7 +9,7 @@ locals macros make math math.order parser quotations sequences
 slots slots.private specialized-arrays vectors words summary
 namespaces assocs vocabs.parser math.functions
 classes.struct.bit-accessors bit-arrays
-stack-checker.dependencies ;
+stack-checker.dependencies system layouts ;
 QUALIFIED: math
 IN: classes.struct
 
@@ -101,7 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 GENERIC: (reader-quot) ( slot -- quot )
 
 M: struct-slot-spec (reader-quot)
-    [ type>> c-type-getter-boxer ]
+    [ type>> c-getter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (reader-quot)
@@ -166,8 +166,6 @@ INSTANCE: struct-c-type value-type
 
 M: struct-c-type c-type ;
 
-M: struct-c-type c-type-stack-align? drop f ;
-
 : if-value-struct ( ctype true false -- )
     [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
 
@@ -187,7 +185,13 @@ M: struct-c-type box-return
     [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
 
 M: struct-c-type stack-size
-    [ heap-size ] [ stack-size ] if-value-struct ;
+    [ heap-size cell align ] [ stack-size ] if-value-struct ;
+
+HOOK: flatten-struct-type cpu ( type -- reps )
+
+M: object flatten-struct-type int-rep (flatten-c-type) ;
+
+M: struct-c-type flatten-c-type flatten-struct-type ;
 
 M: struct-c-type c-struct? drop t ;
 

basis/compiler/alien/alien.factor

@@ -13,16 +13,3 @@ IN: compiler.alien
 
 : alien-return ( params -- type )
     return>> dup large-struct? [ drop void ] when ;
-
-: c-type-stack-align ( type -- align )
-    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
-
-: parameter-align ( n type -- n delta )
-    [ c-type-stack-align align dup ] [ drop ] 2bi - ;
-
-: parameter-offsets ( types -- total offsets )
-    [
-        0 [
-            [ parameter-align drop dup , ] keep stack-size +
-        ] reduce cell align
-    ] { } make ;

basis/compiler/cfg/builder/builder.factor

@@ -218,7 +218,7 @@ M: #terminate emit-node drop ##no-tco end-basic-block ;
     stack-frame new
         swap
         [ return>> return-size >>return ]
-        [ alien-parameters parameter-offsets drop >>params ] bi
+        [ alien-parameters [ stack-size ] map-sum >>params ] bi
         t >>calls-vm? ;
 
 : alien-node-height ( params -- )

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

@@ -78,5 +78,5 @@ IN: compiler.cfg.intrinsics.allot
         :> len
         0 ^^load-literal :> elt
         len emit-allot-byte-array :> reg
-        len reg elt byte-array store-initial-element
+        len cell align cell /i reg elt byte-array store-initial-element
     ] [ drop node emit-primitive ] if ;

basis/compiler/codegen/alien/alien.factor

@@ -6,7 +6,8 @@ classes.struct combinators compiler.alien
 compiler.cfg.instructions compiler.codegen
 compiler.codegen.fixup compiler.errors compiler.utilities
 cpu.architecture fry kernel layouts libc locals make math
-math.order math.parser namespaces quotations sequences strings ;
+math.order math.parser namespaces quotations sequences strings
+system ;
 FROM: compiler.errors => no-such-symbol ;
 IN: compiler.codegen.alien
 
@@ -46,44 +47,11 @@ M: reg-class reg-class-full?
 : alloc-fastcall-param ( rep -- n reg-class rep )
     [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
 
-:: alloc-parameter ( parameter abi -- reg rep )
+:: alloc-parameter ( rep abi -- reg rep )
-    parameter c-type-rep dup reg-class-of abi reg-class-full?
+    rep dup reg-class-of abi reg-class-full?
     [ alloc-stack-param ] [ alloc-fastcall-param ] if
     [ abi param-reg ] dip ;
 
-SYMBOL: (stack-value)
-<< void* c-type clone \ (stack-value) define-primitive-type
-stack-params \ (stack-value) c-type (>>rep) >>
-
-: ((flatten-type)) ( type to-type -- seq )
-    [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
-
-: (flatten-int-type) ( type -- seq )
-    void* ((flatten-type)) ;
-: (flatten-stack-type) ( type -- seq )
-    (stack-value) ((flatten-type)) ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: long-long-type flatten-value-type (flatten-int-type) ;
-M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        0 [
-            c-type
-            [ parameter-align cell /i void* c-type <repetition> % ] keep
-            [ stack-size cell align + ] keep
-            flatten-value-type %
-        ] reduce drop
-    ] { } make ;
-
-: each-parameter ( parameters quot -- )
-    [ [ parameter-offsets nip ] keep ] dip 2each ; inline
-
 : reset-fastcall-counts ( -- )
     { int-regs float-regs stack-params } [ 0 swap set ] each ;
 
@@ -91,19 +59,27 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
     #! In quot you can call alloc-parameter
     [ reset-fastcall-counts call ] with-scope ; inline
 
-: move-parameters ( node word -- )
+:: move-parameters ( params word -- )
     #! Moves values from C stack to registers (if word is
     #! %load-param-reg) and registers to C stack (if word is
     #! %save-param-reg).
-    [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+    0 params alien-parameters flatten-c-types [
-    [ '[ _ alloc-parameter _ execute ] ]
+        [ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
-    bi* each-parameter ; inline
+        [ rep-size cell align + ]
+        2bi
+    ] each drop ; inline
+
+: parameter-offsets ( types -- offsets )
+    0 [ stack-size + ] accumulate nip ;
+
+: each-parameter ( parameters quot -- )
+    [ [ parameter-offsets ] keep ] dip 2each ; inline
 
 : reverse-each-parameter ( parameters quot -- )
-    [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+    [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline
 
 : prepare-unbox-parameters ( parameters -- offsets types indices )
-    [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
+    [ parameter-offsets ] [ ] [ length iota <reversed> ] tri ;
 
 : unbox-parameters ( offset node -- )
     parameters>> swap
@@ -147,7 +123,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
     ] if ;
 
 : decorated-symbol ( params -- symbols )
-    [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+    [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
     {
         [ drop ]
         [ "@" glue ]

basis/cpu/x86/32/32.factor

@@ -326,7 +326,7 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
 
 : stack-arg-size ( params -- n )
     dup abi>> '[
-        alien-parameters flatten-value-types
+        alien-parameters flatten-c-types
         [ _ alloc-parameter 2drop ] each
         stack-params get
     ] with-param-regs ;
@@ -357,11 +357,9 @@ M: x86.32 dummy-int-params? f ;
 M: x86.32 dummy-fp-params? f ;
 
 ! Dreadful
-M: object flatten-value-type (flatten-stack-type) ;
+M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
-M: struct-c-type flatten-value-type (flatten-stack-type) ;
+M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
-M: long-long-type flatten-value-type (flatten-stack-type) ;
+M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ;
-M: c-type flatten-value-type
-    dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
 
 M: x86.32 struct-return-pointer-type
     os linux? void* (stack-value) ? ;

basis/cpu/x86/64/64.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.libraries
 slots splitting assocs combinators locals compiler.constants
-compiler.codegen compiler.codegen.alien compiler.codegen.fixup
+classes.struct compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
@@ -132,9 +132,9 @@ M:: x86.64 %unbox ( n rep func -- )
     ! this is the end of alien-callback
     n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
 
-: %unbox-struct-field ( c-type i -- )
+: %unbox-struct-field ( rep i -- )
     ! Alien must be in param-reg-0.
-    R11 swap cells [+] swap rep>> reg-class-of {
+    R11 swap cells [+] swap reg-class-of {
         { int-regs [ int-regs get pop swap MOV ] }
         { float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
@@ -147,7 +147,7 @@ M: x86.64 %unbox-small-struct ( c-type -- )
     ! clobber it.
     R11 RAX MOV
     [
-        flatten-value-type [ %unbox-struct-field ] each-index
+        flatten-struct-type [ %unbox-struct-field ] each-index
     ] with-return-regs ;
 
 M:: x86.64 %unbox-large-struct ( n c-type -- )
@@ -179,8 +179,8 @@ M:: x86.64 %box ( n rep func -- )
 
 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;
 
-: %box-struct-field ( c-type i -- )
+: %box-struct-field ( rep i -- )
-    box-struct-field@ swap c-type-rep reg-class-of {
+    box-struct-field@ swap reg-class-of {
         { int-regs [ int-regs get pop MOV ] }
         { float-regs [ float-regs get pop MOVSD ] }
     } case ;
@@ -188,7 +188,7 @@ M:: x86.64 %box ( n rep func -- )
 M: x86.64 %box-small-struct ( c-type -- )
     #! Box a <= 16-byte struct.
     [
-        [ flatten-value-type [ %box-struct-field ] each-index ]
+        [ flatten-struct-type [ %box-struct-field ] each-index ]
         [ param-reg-2 swap heap-size MOV ] bi
         param-reg-0 0 box-struct-field@ MOV
         param-reg-1 1 box-struct-field@ MOV

basis/cpu/x86/64/unix/unix.factor

@@ -27,21 +27,16 @@ M: x86.64 reserved-stack-space 0 ;
 : flatten-small-struct ( c-type -- seq )
     struct-types&offset split-struct [
         [ c-type c-type-rep reg-class-of ] map
-        int-regs swap member? void* double ? c-type
+        int-regs swap member? int-rep double-rep ?
     ] map ;
 
 : flatten-large-struct ( c-type -- seq )
-    (flatten-stack-type) ;
+    stack-params (flatten-c-type) ;
 
-: flatten-struct ( c-type -- seq )
+M: x86.64 flatten-struct-type ( c-type -- seq )
-    dup heap-size 16 > [
+    dup heap-size 16 >
-        flatten-large-struct
+    [ flatten-large-struct ]
-    ] [
+    [ flatten-small-struct ] if ;
-        flatten-small-struct
-    ] if ;
-
-M: struct-c-type flatten-value-type ( type -- seq )
-    flatten-struct ;
 
 M: x86.64 return-struct-in-registers? ( c-type -- ? )
     heap-size 2 cells <= ;

basis/functors/functors-tests.factor

@@ -159,7 +159,7 @@ T-class DEFINES-CLASS ${T}
 WHERE
 
 STRUCT: T-class
-    { NAME c:int }
+    { NAME c:longlong }
     { x { TYPE 4 } }
     { y { c:short N } }
     { z TYPE initial: 5 }
@@ -178,32 +178,32 @@ STRUCT: T-class
             { offset 0 }
             { class integer }
             { initial 0 } 
-            { type c:int }
+            { type c:longlong }
         }
         T{ struct-slot-spec
             { name "x" }
-            { offset 4 }
+            { offset 8 }
             { class object }
             { initial f } 
             { type { c:char 4 } }
         }
         T{ struct-slot-spec
             { name "y" }
-            { offset 8 }
+            { offset 12 }
             { class object }
             { initial f } 
             { type { c:short 2 } }
         }
         T{ struct-slot-spec
             { name "z" }
-            { offset 12 }
+            { offset 16 }
             { class fixnum }
             { initial 5 } 
             { type c:char }
         }
         T{ struct-slot-spec
             { name "float" }
-            { offset 16 }
+            { offset 20 }
             { class object }
             { initial f } 
             { type { c:float 2 } }

basis/specialized-arrays/specialized-arrays.factor

@@ -45,7 +45,7 @@ byte-array>A DEFINES byte-array>${A}
 A{           DEFINES ${A}{
 A@           DEFINES ${A}@
 
-NTH          [ T dup c-type-getter-boxer array-accessor ]
+NTH          [ T dup c-getter array-accessor ]
 SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE

basis/vm/vm.factor

@@ -19,10 +19,10 @@ STRUCT: context
 : context-field-offset ( field -- offset ) context offset-of ; inline
 
 STRUCT: zone
-{ start cell }
 { here cell }
-{ size cell }
+{ start cell }
-{ end cell } ;
+{ end cell }
+{ size cell } ;
 
 STRUCT: vm
 { ctx context* }

extra/mason/release/tidy/tidy.factor

@@ -6,17 +6,14 @@ kernel mason.common namespaces sequences ;
 FROM: mason.config => target-os ;
 IN: mason.release.tidy
 
-: common-files ( -- seq )
+: useless-files ( -- seq )
     "build-support/cleanup" ascii file-lines
-    images [ boot-image-name ] map
+    images [ boot-image-name ] map append
-    append ;
+    target-os get "macosx" = [ "Factor.app" suffix ] unless ;
-
-: remove-common-files ( -- )
-    common-files [ really-delete-tree ] each ;
-
-: remove-factor-app ( -- )
-    target-os get "macosx" =
-    [ "Factor.app" really-delete-tree ] unless ;
 
 : tidy ( -- )
-    "factor" [ remove-factor-app remove-common-files ] with-directory ;
+    "factor" [
+        useless-files
+        [ exists? ] filter
+        [ really-delete-tree ] each
+    ] with-directory ;

extra/trees/avl/avl-tests.factor

@@ -1,5 +1,5 @@
 USING: kernel tools.test trees trees.avl math random sequences
-assocs accessors ;
+assocs accessors trees.avl.private trees.private ;
 IN: trees.avl.tests
 
 [ "key1" 0 "key2" 0 ] [

extra/trees/avl/avl.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators kernel generic math math.functions
 math.parser namespaces io sequences trees shuffle
-assocs parser accessors math.order prettyprint.custom ;
+assocs parser accessors math.order prettyprint.custom
+trees.private ;
 IN: trees.avl
 
 TUPLE: avl < tree ;
@@ -10,6 +11,8 @@ TUPLE: avl < tree ;
 : <avl> ( -- tree )
     avl new-tree ;
 
+<PRIVATE
+
 TUPLE: avl-node < node balance ;
 
 : <avl-node> ( key value -- node )
@@ -20,11 +23,14 @@ TUPLE: avl-node < node balance ;
     swap [ + ] change-balance drop ;
 
 : rotate ( node -- node )
-    dup node+link dup node-link pick set-node+link
+    dup node+link
-    tuck set-node-link ;    
+    dup node-link
+    pick set-node+link
+    [ set-node-link ] keep ;    
 
 : single-rotate ( node -- node )
-    0 over (>>balance) 0 over node+link 
+    0 >>balance
+    0 over node+link 
     (>>balance) rotate ;
 
 : pick-balances ( a node -- balance balance )
@@ -61,7 +67,7 @@ DEFER: avl-set
 : avl-insert ( value key node -- node taller? )
     2dup key>> before? left right ? [
         [ node-link avl-set ] keep swap
-        [ tuck set-node-link ] dip
+        [ [ set-node-link ] keep ] dip
         [ dup current-side get increase-balance balance-insert ]
         [ f ] if
     ] with-side ;
@@ -146,6 +152,8 @@ M: avl delete-at ( key node -- )
 
 M: avl new-assoc 2drop <avl> ;
 
+PRIVATE>
+
 : >avl ( assoc -- avl )
     T{ avl f f 0 } assoc-clone-like ;
 

extra/trees/splay/splay.factor

@@ -1,7 +1,8 @@
 ! Copyright (c) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math namespaces sequences assocs parser
-trees generic math.order accessors prettyprint.custom shuffle ;
+trees generic math.order accessors prettyprint.custom
+trees.private combinators ;
 IN: trees.splay
 
 TUPLE: splay < tree ;
@@ -9,6 +10,8 @@ TUPLE: splay < tree ;
 : <splay> ( -- tree )
     \ splay new-tree ;
 
+<PRIVATE
+
 : rotate-right ( node -- node )
     dup left>>
     [ right>> swap (>>left) ] 2keep
@@ -27,32 +30,35 @@ TUPLE: splay < tree ;
     swap [ rot [ (>>right) ] 2keep
     drop dup right>> swapd ] dip swap ;
 
-: cmp ( key node -- obj node -1/0/1 )
+: cmp ( key node -- obj node <=> )
-    2dup key>> key-side ;
+    2dup key>> <=> ;
 
-: lcmp ( key node -- obj node -1/0/1 ) 
+: lcmp ( key node -- obj node <=> ) 
-    2dup left>> key>> key-side ;
+    2dup left>> key>> <=> ;
 
-: rcmp ( key node -- obj node -1/0/1 ) 
+: rcmp ( key node -- obj node <=> ) 
-    2dup right>> key>> key-side ;
+    2dup right>> key>> <=> ;
 
 DEFER: (splay)
 
 : splay-left ( left right key node -- left right key node )
     dup left>> [
-        lcmp 0 < [ rotate-right ] when
+        lcmp +lt+ = [ rotate-right ] when
         dup left>> [ link-right (splay) ] when
     ] when ;
 
 : splay-right ( left right key node -- left right key node )
     dup right>> [
-        rcmp 0 > [ rotate-left ] when
+        rcmp +gt+ = [ rotate-left ] when
         dup right>> [ link-left (splay) ] when
     ] when ;
 
 : (splay) ( left right key node -- left right key node )
-    cmp dup 0 <
+    cmp {
-    [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
+        { +lt+ [ splay-left ] }
+        { +gt+ [ splay-right ] }
+        { +eq+ [ ] }
+    } case ;
 
 : assemble ( head left right node -- root )
     [ right>> swap (>>left) ] keep
@@ -64,18 +70,18 @@ DEFER: (splay)
     [ T{ node } clone dup dup ] 2dip
     (splay) nip assemble ;
 
-: splay ( key tree -- )
+: do-splay ( key tree -- )
     [ root>> splay-at ] keep (>>root) ;
 
 : splay-split ( key tree -- node node )
-    2dup splay root>> cmp 0 < [
+    2dup do-splay root>> cmp +lt+ = [
         nip dup left>> swap f over (>>left)
     ] [
         nip dup right>> swap f over (>>right) swap
     ] if ;
 
 : get-splay ( key tree -- node ? )
-    2dup splay root>> cmp 0 = [
+    2dup do-splay root>> cmp +eq+ = [
         nip t
     ] [
         2drop f f
@@ -95,7 +101,7 @@ DEFER: (splay)
     ] if* ;
 
 : remove-splay ( key tree -- )
-    tuck get-splay nip [
+    [ get-splay nip ] keep [
         dup dec-count
         dup right>> swap left>> splay-join
         swap (>>root)
@@ -128,6 +134,8 @@ M: splay delete-at ( key tree -- )
 M: splay new-assoc
     2drop <splay> ;
 
+PRIVATE>
+
 : >splay ( assoc -- tree )
     T{ splay f f 0 } assoc-clone-like ;
 

extra/trees/trees.factor

@@ -2,22 +2,27 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic math sequences arrays io namespaces
 prettyprint.private kernel.private assocs random combinators
-parser math.order accessors deques make prettyprint.custom 
+parser math.order accessors deques make prettyprint.custom ;
-shuffle ;
 IN: trees
 
 TUPLE: tree root count ;
 
+<PRIVATE
+
 : new-tree ( class -- tree )
     new
         f >>root
         0 >>count ; inline
 
+PRIVATE>
+
 : <tree> ( -- tree )
     tree new-tree ;
 
 INSTANCE: tree assoc
 
+<PRIVATE
+
 TUPLE: node key value left right ;
 
 : new-node ( key value class -- node )
@@ -61,7 +66,7 @@ CONSTANT: right 1
 : set-node+link ( child node -- ) t set-node-link@ ;
 
 : with-side ( side quot -- )
-    [ swap current-side set call ] with-scope ; inline
+    [ current-side ] dip with-variable ; inline
 
 : with-other-side ( quot -- )
     current-side get neg swap with-side ; inline
@@ -137,9 +142,9 @@ DEFER: delete-node
 
 : (prune-extremity) ( parent node -- new-extremity )
     dup node-link [
-        rot drop (prune-extremity)
+        [ nip ] dip (prune-extremity)
     ] [
-        tuck delete-node swap set-node-link
+        [ delete-node ] [ set-node-link ] bi
     ] if* ;
 
 : prune-extremity ( node -- new-extremity )
@@ -183,9 +188,15 @@ DEFER: delete-node
     2dup key>> key-side dup 0 eq? [
         drop nip delete-node
     ] [
-        [ tuck node-link delete-bst-node over set-node-link ] with-side
+        [
+            [ node-link delete-bst-node ]
+            [ set-node-link ]
+            [ ] tri
+        ] with-side
     ] if ;
 
+PRIVATE>
+
 M: tree delete-at
     [ delete-bst-node ] change-root drop ;
 

vm/booleans.cpp

@@ -3,14 +3,4 @@
 namespace factor
 {
 
-VM_C_API bool to_boolean(cell value, factor_vm *parent)
-{
-	return to_boolean(value);
-}
-
-VM_C_API cell from_boolean(bool value, factor_vm *parent)
-{
-	return parent->tag_boolean(value);
-}
-
 }

vm/booleans.hpp

@@ -1,9 +1,6 @@
 namespace factor
 {
 
-VM_C_API bool to_boolean(cell value, factor_vm *vm);
-VM_C_API cell from_boolean(bool value, factor_vm *vm);
-
 /* Cannot allocate */
 inline static bool to_boolean(cell value)
 {