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

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

db4
Daniel Ehrenberg 2010-05-05 08:54:47 -05:00
parent 4d5b7fe883 aaa706dd29
commit ea69bd68ac
24 changed files with 233 additions and 262 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 =

193
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,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 [
[ "Cannot read struct fields with this type" throw ]
] unless* ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with this type" throw ]
] unless* ;
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
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
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
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
bootstrap-cell >>align
bootstrap-cell >>align-first
8 >>size
8 >>align
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 ;

3
basis/alien/data/data.factor
View File

@ -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
'[ @ swap @ _ memcpy ] ;
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
M: array c-type-boxer-quot
unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;

2
basis/alien/parser/parser.factor
View File

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

12
basis/bootstrap/compiler/timing/timing.factor
View File

@ -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.stacks.global
QUALIFIED: compiler.cfg.finalization
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 ,

4
basis/classes/struct/struct-tests.factor
View File

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

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

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

2
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

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

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 ]

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

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

2
basis/specialized-arrays/specialized-arrays.factor
View File

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

6
basis/vm/vm.factor
View File

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

19
extra/mason/release/tidy/tidy.factor
View File

@ -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
append ;
: remove-common-files ( -- )
common-files [ really-delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
[ "Factor.app" really-delete-tree ] unless ;
images [ boot-image-name ] map append
target-os get "macosx" = [ "Factor.app" suffix ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;
"factor" [
useless-files
[ exists? ] filter
[ really-delete-tree ] each
] with-directory ;

2
extra/trees/avl/avl-tests.factor
View File

@ -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 ] [

18
extra/trees/avl/avl.factor
View File

@ -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
tuck set-node-link ;
dup 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 ;

38
extra/trees/splay/splay.factor
View File

@ -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 )
2dup key>> key-side ;
: cmp ( key node -- obj node <=> )
2dup key>> <=> ;
: lcmp ( key node -- obj node -1/0/1 )
2dup left>> key>> key-side ;
: lcmp ( key node -- obj node <=> )
2dup left>> key>> <=> ;
: rcmp ( key node -- obj node -1/0/1 )
2dup right>> key>> key-side ;
: rcmp ( key node -- obj node <=> )
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 <
[ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
cmp {
{ +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 ;

23
extra/trees/trees.factor
View File

@ -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
shuffle ;
parser math.order accessors deques make prettyprint.custom ;
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 ;

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