Merge branch 'master' of factorcode.org:/git/factor into cuda-changes

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,9 +143,16 @@ 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
 
@@ -179,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 ;
@@ -214,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 ;
@@ -259,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 )
@@ -505,6 +503,9 @@ M: pointer c-type
         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/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
 
@@ -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/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

@@ -5,11 +5,10 @@ arrays kernel fry math namespaces sequences system layouts io
 vocabs.loader accessors init classes.struct combinators
 command-line make words compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
-compiler.codegen.alien compiler.codegen.fixup
+compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.builder compiler.cfg.intrinsics
-compiler.cfg.intrinsics compiler.cfg.stack-frame
+compiler.cfg.stack-frame cpu.x86.assembler
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
-cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 
@@ -326,7 +325,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 +356,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 } }

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)
 {