steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2010-05-04 22:21:21 -07:00
parent 7c89fb2438 e763c74096
commit 0e0e89ae3a
12 changed files with 88 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/alien/arrays/arrays.factor
View File

@ -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
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 =

57
basis/alien/c-types/c-types.factor
View File

@ -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 }
stack-align? ;
{ rep initial: int-rep } ;
: <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
%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 -- )
@ -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 ;

12
basis/classes/struct/struct.factor
View File

@ -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 ;

13
basis/compiler/alien/alien.factor
View File

@ -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 ;

2
basis/compiler/cfg/builder/builder.factor
View File

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

62
basis/compiler/codegen/alien/alien.factor
View File

@ -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 )
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 ;
@ -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 ]
[ '[ _ 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
@ -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 ]

19
basis/cpu/x86/32/32.factor
View File

@ -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.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
@ -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-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) ? ;

14
basis/cpu/x86/64/64.factor
View File

@ -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@ 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 ;
@ -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

17
basis/cpu/x86/64/unix/unix.factor
View File

@ -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 )
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 <= ;

12
basis/functors/functors-tests.factor
View File

@ -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 } }

10
vm/booleans.cpp
View File

@ -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);
}
}

3
vm/booleans.hpp
View File

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