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

Converting core to use inheritance

db4
Slava Pestov 2008-04-04 03:46:30 -05:00
parent ef4046cda9
commit 82fc8f18db
19 changed files with 269 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/arrays/arrays.factor
View File

@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; M: array stack-size drop "void*" stack-size ;
M: value-type c-type-reg-class drop T{ int-regs } ; M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ; M: value-type c-type-prep drop f ;

245
core/alien/c-types/c-types.factor
View File

@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary ; layouts system compiler.units io.files io.encodings.binary
accessors combinators ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -17,8 +18,12 @@ boxer prep unboxer
getter setter getter setter
reg-class size align stack-align? ; reg-class size align stack-align? ;
: construct-c-type ( class -- type )
construct-empty
int-regs >>reg-class ;
: <c-type> ( -- type ) : <c-type> ( -- type )
T{ int-regs } { set-c-type-reg-class } \ c-type construct ; \ c-type construct-c-type ;
SYMBOL: c-types SYMBOL: c-types
@ -181,10 +186,10 @@ DEFER: >c-ushort-array
: define-c-type ( type name vocab -- ) : define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ; >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
TUPLE: long-long-type ; TUPLE: long-long-type < c-type ;
: <long-long-type> ( type -- type ) : <long-long-type> ( -- type )
long-long-type construct-delegate ; long-long-type construct-c-type ;
M: long-long-type unbox-parameter ( n type -- ) M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ; c-type-unboxer %unbox-long-long ;
@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
: define-from-array ( type vocab -- ) : define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ; [ from-array-word ] 2keep c-array>quot define ;
: <primitive-type> ( getter setter width boxer unboxer -- type )
<c-type>
[ set-c-type-unboxer ] keep
[ set-c-type-boxer ] keep
[ set-c-type-size ] 2keep
[ set-c-type-align ] keep
[ set-c-type-setter ] keep
[ set-c-type-getter ] keep ;
: define-primitive-type ( type name -- ) : define-primitive-type ( type name -- )
"alien.c-types" "alien.c-types"
[ define-c-type ] 2keep {
[ define-deref ] 2keep [ define-c-type ]
[ define-to-array ] 2keep [ define-deref ]
[ define-from-array ] 2keep [ define-to-array ]
define-out ; [ define-from-array ]
[ define-out ]
} 2cleave ;
: expand-constants ( c-type -- c-type' ) : expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around #! We use word-def call instead of execute to get around
@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- )
binary file-contents dup malloc-byte-array swap length ; binary file-contents dup malloc-byte-array swap length ;
[ [
[ alien-cell ] <c-type>
[ set-alien-cell ] [ alien-cell ] >>getter
bootstrap-cell [ set-alien-cell ] >>setter
"box_alien" bootstrap-cell >>size
"alien_offset" <primitive-type> bootstrap-cell >>align
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type "void*" define-primitive-type
[ alien-signed-8 ] <long-long-type>
[ set-alien-signed-8 ] [ alien-signed-8 ] >>getter
8 [ set-alien-signed-8 ] >>setter
"box_signed_8" 8 >>size
"to_signed_8" <primitive-type> <long-long-type> 8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
"longlong" define-primitive-type "longlong" define-primitive-type
[ alien-unsigned-8 ] <long-long-type>
[ set-alien-unsigned-8 ] [ alien-unsigned-8 ] >>getter
8 [ set-alien-unsigned-8 ] >>setter
"box_unsigned_8" 8 >>size
"to_unsigned_8" <primitive-type> <long-long-type> 8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type "ulonglong" define-primitive-type
[ alien-signed-cell ] <c-type>
[ set-alien-signed-cell ] [ alien-signed-cell ] >>getter
bootstrap-cell [ set-alien-signed-cell ] >>setter
"box_signed_cell" bootstrap-cell >>size
"to_fixnum" <primitive-type> bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
"long" define-primitive-type "long" define-primitive-type
[ alien-unsigned-cell ] <c-type>
[ set-alien-unsigned-cell ] [ alien-unsigned-cell ] >>getter
bootstrap-cell [ set-alien-unsigned-cell ] >>setter
"box_unsigned_cell" bootstrap-cell >>size
"to_cell" <primitive-type> bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
"ulong" define-primitive-type "ulong" define-primitive-type
[ alien-signed-4 ] <c-type>
[ set-alien-signed-4 ] [ alien-signed-4 ] >>getter
4 [ set-alien-signed-4 ] >>setter
"box_signed_4" 4 >>size
"to_fixnum" <primitive-type> 4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
"int" define-primitive-type "int" define-primitive-type
[ alien-unsigned-4 ] <c-type>
[ set-alien-unsigned-4 ] [ alien-unsigned-4 ] >>getter
4 [ set-alien-unsigned-4 ] >>setter
"box_unsigned_4" 4 >>size
"to_cell" <primitive-type> 4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
"uint" define-primitive-type "uint" define-primitive-type
[ alien-signed-2 ] <c-type>
[ set-alien-signed-2 ] [ alien-signed-2 ] >>getter
2 [ set-alien-signed-2 ] >>setter
"box_signed_2" 2 >>size
"to_fixnum" <primitive-type> 2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
"short" define-primitive-type "short" define-primitive-type
[ alien-unsigned-2 ] <c-type>
[ set-alien-unsigned-2 ] [ alien-unsigned-2 ] >>getter
2 [ set-alien-unsigned-2 ] >>setter
"box_unsigned_2" 2 >>size
"to_cell" <primitive-type> 2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
"ushort" define-primitive-type "ushort" define-primitive-type
[ alien-signed-1 ] <c-type>
[ set-alien-signed-1 ] [ alien-signed-1 ] >>getter
1 [ set-alien-signed-1 ] >>setter
"box_signed_1" 1 >>size
"to_fixnum" <primitive-type> 1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
"char" define-primitive-type "char" define-primitive-type
[ alien-unsigned-1 ] <c-type>
[ set-alien-unsigned-1 ] [ alien-unsigned-1 ] >>getter
1 [ set-alien-unsigned-1 ] >>setter
"box_unsigned_1" 1 >>size
"to_cell" <primitive-type> 1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
"uchar" define-primitive-type "uchar" define-primitive-type
[ alien-unsigned-4 zero? not ] <c-type>
[ 1 0 ? set-alien-unsigned-4 ] [ alien-unsigned-4 zero? not ] >>getter
4 [ 1 0 ? set-alien-unsigned-4 ] >>setter
"box_boolean" 4 >>size
"to_boolean" <primitive-type> 4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type "bool" define-primitive-type
[ alien-float ] <c-type>
[ >r >r >float r> r> set-alien-float ] [ alien-float ] >>getter
4 [ >r >r >float r> r> set-alien-float ] >>setter
"box_float" 4 >>size
"to_float" <primitive-type> 4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
[ >float ] >>prep
"float" define-primitive-type "float" define-primitive-type
T{ float-regs f 4 } "float" c-type set-c-type-reg-class <c-type>
[ >float ] "float" c-type set-c-type-prep [ alien-double ] >>getter
[ >r >r >float r> r> set-alien-double ] >>setter
[ alien-double ] 8 >>size
[ >r >r >float r> r> set-alien-double ] 8 >>align
8 "box_double" >>boxer
"box_double" "to_double" >>unboxer
"to_double" <primitive-type> double-float-regs >>reg-class
[ >float ] >>prep
"double" define-primitive-type "double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class <c-type>
[ >float ] "double" c-type set-c-type-prep [ alien-cell alien>char-string ] >>getter
[ set-alien-cell ] >>setter
[ alien-cell alien>char-string ] bootstrap-cell >>size
[ set-alien-cell ] bootstrap-cell >>align
bootstrap-cell "box_char_string" >>boxer
"box_char_string" "alien_offset" >>unboxer
"alien_offset" <primitive-type> [ string>char-alien ] >>prep
"char*" define-primitive-type "char*" define-primitive-type
"char*" "uchar*" typedef "char*" "uchar*" typedef
[ string>char-alien ] "char*" c-type set-c-type-prep <c-type>
[ alien-cell alien>u16-string ] >>getter
[ alien-cell alien>u16-string ] [ set-alien-cell ] >>setter
[ set-alien-cell ] 4 >>size
4 4 >>align
"box_u16_string" "box_u16_string" >>boxer
"alien_offset" <primitive-type> "alien_offset" >>unboxer
[ string>u16-alien ] >>prep
"ushort*" define-primitive-type "ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit ] with-compilation-unit

34
core/alien/compiler/compiler.factor
View File

@ -70,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ; M: int-regs reg-size drop cell ;
M: float-regs reg-size float-regs-size ; M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- ) GENERIC: inc-reg-class ( register-class -- )
: (inc-reg-class) M: reg-class inc-reg-class
dup class inc dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs inc-reg-class M: float-regs inc-reg-class
dup (inc-reg-class) dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ; fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? ) : reg-class-full? ( class -- ? )
dup class get swap param-regs length >= ; [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class ) : spill-param ( reg-class -- n reg-class )
reg-size stack-params dup get -rot +@ T{ stack-params } ; stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class ) : fastcall-param ( reg-class -- n reg-class )
[ dup class get swap inc-reg-class ] keep ; [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class ) : alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full? c-type-reg-class dup reg-class-full?
@ -323,7 +330,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- ) : callback-bottom ( node -- )
alien-callback-xt [ word-xt drop <alien> ] curry xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ; recursive-state get infer-quot ;
\ alien-callback [ \ alien-callback [
@ -373,8 +380,7 @@ TUPLE: callback-context ;
: wrap-callback-quot ( node -- quot ) : wrap-callback-quot ( node -- quot )
[ [
dup alien-callback-quot [ quot>> ] [ prepare-callback-return ] bi append ,
swap prepare-callback-return append ,
[ callback-context construct-empty do-callback ] % [ callback-context construct-empty do-callback ] %
] [ ] make ; ] [ ] make ;
@ -395,7 +401,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ; callback-unwind %unwind ;
: generate-callback ( node -- ) : generate-callback ( node -- )
dup alien-callback-xt dup [ dup xt>> dup [
init-templates init-templates
%save-word-xt %save-word-xt
%prologue-later %prologue-later

4
core/classes/tuple/tuple-tests.factor
View File

@ -218,7 +218,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[ [
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with ] [ error>> no-tuple-class? ] must-fail-with
! Inheritance ! Inheritance
TUPLE: computer cpu ram ; TUPLE: computer cpu ram ;
@ -488,7 +488,7 @@ USE: vocabs
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with [ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten... ! Accessors not being forgotten...
[ [ ] ] [ [ [ ] ] [

8
core/compiler/tests/templates-early.factor
View File

@ -4,7 +4,7 @@ USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ; words kernel math effects definitions compiler.units ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ; : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[ [
[ ] [ init-templates ] unit-test [ ] [ init-templates ] unit-test
@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
[ ] [ compute-free-vregs ] unit-test [ ] [ compute-free-vregs ] unit-test
[ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [ [ f ] [
[ [
copy-templates copy-templates
1 <int-vreg> phantom-push 1 <int-vreg> phantom-push
compute-free-vregs compute-free-vregs
1 <int-vreg> T{ int-regs } free-vregs member? 1 <int-vreg> int-regs free-vregs member?
] with-scope ] with-scope
] unit-test ] unit-test
[ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope ] with-scope
[ [

44
core/compiler/tests/templates.factor
View File

@ -202,3 +202,47 @@ TUPLE: my-tuple ;
] [ 2drop no-case ] if ] [ 2drop no-case ] if
] compile-call ] compile-call
] unit-test ] unit-test
: float-spill-bug
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test

2
core/cpu/architecture/architecture.factor
View File

@ -6,7 +6,7 @@ byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack ! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ; SINGLETON: stack-params
! Return values of this class go here ! Return values of this class go here
GENERIC: return-reg ( register-class -- reg ) GENERIC: return-reg ( register-class -- reg )

12
core/cpu/ppc/architecture/architecture.factor
View File

@ -146,11 +146,19 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
: STF float-regs-size 4 = [ STFS ] [ STFD ] if ; GENERIC: STF ( src dst reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
: LF float-regs-size 4 = [ LFS ] [ LFD ] if ; GENERIC: LF ( src dst reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ; M: float-regs %load-param-reg >r 1 rot local@ r> LF ;

2
core/cpu/x86/32/32.factor
View File

@ -155,7 +155,7 @@ M: x86.32 %box ( n reg-class func -- )
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C. #! boxing a parameter being passed to a callback from C.
[ [
T{ int-regs } box@ int-regs box@
EDX over stack@ MOV EDX over stack@ MOV
EAX swap cell - stack@ MOV EAX swap cell - stack@ MOV
] when* ] when*

8
core/cpu/x86/64/64.factor
View File

@ -65,7 +65,7 @@ M: x86.64 %unbox ( n reg-class func -- )
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- ) M: x86.64 %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ; int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- ) M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
@ -103,7 +103,7 @@ M: x86.64 %box ( n reg-class func -- )
f %alien-invoke ; f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ; int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ; M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
@ -170,7 +170,7 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up ! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type << "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >> stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs ) : struct-types&offset ( struct-type -- pairs )
struct-type-fields [ struct-type-fields [
@ -192,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq )
] [ ] [
struct-types&offset split-struct [ struct-types&offset split-struct [
[ c-type c-type-reg-class ] map [ c-type c-type-reg-class ] map
T{ int-regs } swap member? int-regs swap member?
"void*" "double" ? c-type , "void*" "double" ? c-type ,
] each ] each
] if ; ] if ;

8
core/cpu/x86/architecture/architecture.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math cpu.x86.assembler cpu.architecture kernel kernel.private math
@ -22,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ; M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ; M: int-regs %load-param-reg drop swap stack@ MOV ;
: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ; GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ; M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;

55
core/generator/registers/registers.factor
View File

@ -3,7 +3,8 @@
USING: arrays assocs classes classes.private classes.algebra USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays ; words effects alien byte-arrays bit-arrays float-arrays
accessors ;
IN: generator.registers IN: generator.registers
SYMBOL: +input+ SYMBOL: +input+
@ -13,9 +14,11 @@ SYMBOL: +clobber+
SYMBOL: known-tag SYMBOL: known-tag
! Register classes ! Register classes
TUPLE: int-regs ; SINGLETON: int-regs
SINGLETON: single-float-regs
TUPLE: float-regs size ; SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
<PRIVATE <PRIVATE
@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ; M: value lazy-store 2drop ;
! A scratch register for computations ! A scratch register for computations
TUPLE: vreg n ; TUPLE: vreg n reg-class ;
: <vreg> ( n reg-class -- vreg ) C: <vreg> vreg ( n reg-class -- vreg )
{ set-vreg-n set-delegate } vreg construct ;
M: vreg v>operand dup vreg-n swap vregs nth ; M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ; M: vreg live-vregs* , ;
M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value INSTANCE: vreg value
@ -62,9 +65,9 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ; M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling ! Temporary register for stack shuffling
TUPLE: temp-reg ; TUPLE: temp-reg reg-class>> ;
: temp-reg T{ temp-reg T{ int-regs } } ; : temp-reg T{ temp-reg f int-regs } ;
M: temp-reg move-spec drop f ; M: temp-reg move-spec drop f ;
@ -73,7 +76,7 @@ INSTANCE: temp-reg value
! A data stack location. ! A data stack location.
TUPLE: ds-loc n class ; TUPLE: ds-loc n class ;
: <ds-loc> { set-ds-loc-n } ds-loc construct ; : <ds-loc> f ds-loc construct-boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ; M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ; M: ds-loc operand-class* ds-loc-class ;
@ -84,8 +87,7 @@ M: ds-loc live-loc?
! A retain stack location. ! A retain stack location.
TUPLE: rs-loc n class ; TUPLE: rs-loc n class ;
: <rs-loc> { set-rs-loc-n } rs-loc construct ; : <rs-loc> f rs-loc construct-boa ;
M: rs-loc operand-class* rs-loc-class ; M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ; M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc? M: rs-loc live-loc?
@ -126,7 +128,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ; TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) : <tagged> ( vreg -- tagged )
{ set-tagged-vreg } tagged construct ; f tagged construct-boa ;
M: tagged v>operand tagged-vreg v>operand ; M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ; M: tagged set-operand-class set-tagged-class ;
@ -340,8 +342,7 @@ SYMBOL: fresh-objects
! Computing free registers and initializing allocator ! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class ) : reg-spec>class ( spec -- class )
float eq? float eq? double-float-regs int-regs ? ;
T{ float-regs f 8 } T{ int-regs } ? ;
: free-vregs ( reg-class -- seq ) : free-vregs ( reg-class -- seq )
#! Free vregs in a given register class #! Free vregs in a given register class
@ -393,7 +394,7 @@ M: value (lazy-load)
: compute-free-vregs ( -- ) : compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable. #! Create a new hashtable for thee free-vregs variable.
live-vregs live-vregs
{ T{ int-regs } T{ float-regs f 8 } } { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc [ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set \ free-vregs set
drop ; drop ;
@ -442,7 +443,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? ) : fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all #! Test if we have enough free registers to load all
#! shuffle inputs at once. #! shuffle inputs at once.
T{ int-regs } free-vregs [ length ] bi@ <= ; int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- ) : finalize-locs ( -- )
#! Perform any deferred stack shuffling. #! Perform any deferred stack shuffling.
@ -483,8 +484,8 @@ M: loc lazy-store
! Loading stacks to vregs ! Loading stacks to vregs
: free-vregs? ( int# float# -- ? ) : free-vregs? ( int# float# -- ? )
T{ float-regs f 8 } free-vregs length <= double-float-regs free-vregs length <=
>r T{ int-regs } free-vregs length <= r> and ; >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' ) : phantom&spec ( phantom spec -- phantom' spec' )
[ length f pad-left ] keep [ length f pad-left ] keep
@ -534,7 +535,7 @@ M: loc lazy-store
: count-input-vregs ( phantom spec -- ) : count-input-vregs ( phantom spec -- )
phantom&spec [ phantom&spec [
>r dup cached? [ cached-vreg ] when r> allocation >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ; ] 2map count-vregs ;
: count-scratch-regs ( spec -- ) : count-scratch-regs ( spec -- )
@ -542,13 +543,13 @@ M: loc lazy-store
: guess-vregs ( dinput rinput scratch -- int# float# ) : guess-vregs ( dinput rinput scratch -- int# float# )
H{ H{
{ T{ int-regs } 0 } { int-regs 0 }
{ T{ float-regs 8 } 0 } { double-float-regs 0 }
} clone [ } clone [
count-scratch-regs count-scratch-regs
phantom-r get swap count-input-vregs phantom-r get swap count-input-vregs
phantom-d get swap count-input-vregs phantom-d get swap count-input-vregs
T{ int-regs } get T{ float-regs 8 } get int-regs get double-float-regs get
] bind ; ] bind ;
: alloc-scratch ( -- ) : alloc-scratch ( -- )
@ -581,12 +582,6 @@ M: loc lazy-store
2drop t 2drop t
] if ; ] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f ) : class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ; class-tags dup length 1 = [ first ] [ drop f ] if ;

4
core/kernel/kernel-docs.factor
View File

@ -217,9 +217,7 @@ $nl
{ $example "\\ f class ." "word" } { $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." "On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" } { $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." "Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
$nl
"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
ARTICLE: "conditionals" "Conditionals and logic" ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:" "The basic conditionals:"

3
core/memory/memory-tests.factor
View File

@ -1,5 +1,6 @@
USING: generic kernel kernel.private math memory prettyprint USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes ; sequences tools.test words namespaces layouts classes
classes.builtin ;
IN: memory.tests IN: memory.tests
TUPLE: testing x y z ; TUPLE: testing x y z ;

6
core/optimizer/optimizer-tests.factor
View File

@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * )
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
: test-2 ( -- ) 5 test-1 ;
[ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( m -- n ) : branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline t [ ] [ 1+ branch-fold-regression-0 ] if ; inline

14
core/parser/parser-tests.factor
View File

@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs sorting classes.tuple compiler.units debugger vocabs
vocabs.loader ; vocabs.loader accessors ;
IN: parser.tests IN: parser.tests
[ [
@ -297,12 +297,12 @@ IN: parser.tests
[ [
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream <string-reader> "removing-the-predicate" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with ] [ error>> error>> redefine-error? ] must-fail-with
[ [
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream <string-reader> "redefining-a-class-1" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
@ -312,7 +312,7 @@ IN: parser.tests
[ [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests TUPLE: class-fwd-test ;" "IN: parser.tests TUPLE: class-fwd-test ;"
@ -322,7 +322,7 @@ IN: parser.tests
[ [
"IN: parser.tests \\ class-fwd-test" "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word-error? ] is? ] must-fail-with ] [ error>> error>> no-word-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@ -332,12 +332,12 @@ IN: parser.tests
[ [
"IN: parser.tests \\ class-fwd-test" "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop <string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word-error? ] is? ] must-fail-with ] [ error>> error>> no-word-error? ] must-fail-with
[ [
"IN: parser.tests : foo ; TUPLE: foo ;" "IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop <string-reader> "redefining-a-class-4" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [ [ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval

4
core/syntax/syntax-docs.factor
View File

@ -333,8 +333,8 @@ HELP: C{
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ; { $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{ HELP: T{
{ $syntax "T{ class delegate slots... }" } { $syntax "T{ class slots... }" }
{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } } { $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "." { $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
$nl $nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ; "The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;

4
core/vocabs/loader/loader-tests.factor
View File

@ -3,7 +3,7 @@ IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs ; debugger compiler.units tools.vocabs accessors ;
! This vocab should not exist, but just in case... ! This vocab should not exist, but just in case...
[ ] [ [ ] [
@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader> <string-reader>
"resource:core/vocabs/loader/test/a/a.factor" "resource:core/vocabs/loader/test/a/a.factor"
parse-stream parse-stream
] [ [ no-word-error? ] is? ] must-fail-with ] [ error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global 0 "count-me" set-global

4
core/words/words-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays generic assocs kernel math namespaces USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units vocabs continuations classes.tuple compiler.units
io.streams.string ; io.streams.string accessors ;
IN: words.tests IN: words.tests
[ 4 ] [ [ 4 ] [
@ -147,7 +147,7 @@ SYMBOL: quot-uses-b
] when* ] when*
[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ "IN: words.tests : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with [ error>> undefined? ] must-fail-with
[ ] [ [ ] [
"IN: words.tests GENERIC: symbol-generic" eval "IN: words.tests GENERIC: symbol-generic" eval