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 ;
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 ;
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 ;
M: string-type c-type-rep
drop int-rep ;
-M: string-type c-type-boxer
- drop void* c-type-boxer ;
-
-M: string-type c-type-unboxer
- drop void* c-type-unboxer ;
+M: string-type flatten-c-type
+ drop { int-rep } ;
M: string-type c-type-boxer-quot
second dup binary =
-! 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
long ulong
longlong ulonglong
float double
- void* bool ;
+ void* bool
+ (stack-value) ;
SINGLETON: void
TUPLE: c-type < abstract-c-type
boxer
unboxer
-{ rep initial: int-rep }
-stack-align? ;
+{ rep initial: int-rep } ;
: <c-type> ( -- c-type )
\ c-type new ; inline
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>> ;
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
- %box ;
+ [ rep>> ] [ boxer>> ] bi %box ;
: c-type-unbox ( n c-type -- )
- [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi
- %unbox ;
+ [ rep>> ] [ unboxer>> ] bi %unbox ;
GENERIC: box-parameter ( n c-type -- )
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
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 ;
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 ;
: (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 )
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 ;
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
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
[ %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 ;
: 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 ;
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 -- )
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
: 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 )
- parameter c-type-rep dup reg-class-of abi reg-class-full?
+:: alloc-parameter ( rep abi -- reg rep )
+ 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 ;
#! 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 ]
- [ '[ _ alloc-parameter _ execute ] ]
- bi* each-parameter ; inline
+ 0 params alien-parameters flatten-c-types [
+ [ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
+ [ 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
] if ;
: decorated-symbol ( params -- symbols )
- [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+ [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
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.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture vm ;
+compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame cpu.x86.assembler
+cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
FROM: layouts => cell ;
IN: cpu.x86.32
: 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 ;
M: x86.32 dummy-fp-params? f ;
! Dreadful
-M: object flatten-value-type (flatten-stack-type) ;
-M: struct-c-type flatten-value-type (flatten-stack-type) ;
-M: long-long-type flatten-value-type (flatten-stack-type) ;
-M: c-type flatten-value-type
- dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
+M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
+M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
+M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type)) ;
M: x86.32 struct-return-pointer-type
os linux? void* (stack-value) ? ;
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
! 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 ;
! 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 -- )
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
-: %box-struct-field ( c-type i -- )
- box-struct-field@ swap c-type-rep reg-class-of {
+: %box-struct-field ( rep i -- )
+ box-struct-field@ swap reg-class-of {
{ int-regs [ int-regs get pop MOV ] }
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
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
: 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 )
- dup heap-size 16 > [
- flatten-large-struct
- ] [
- flatten-small-struct
- ] if ;
-
-M: struct-c-type flatten-value-type ( type -- seq )
- flatten-struct ;
+M: x86.64 flatten-struct-type ( c-type -- seq )
+ dup heap-size 16 >
+ [ flatten-large-struct ]
+ [ flatten-small-struct ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
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);
-}
-
}
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)
{