Converting core to use inheritance
Slava Pestov
parent
ef4046cda9
commit
82fc8f18db
|
|
@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
|
|||
generator.registers assocs kernel kernel.private libc math
|
||||
namespaces parser sequences strings words assocs splitting
|
||||
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
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -17,8 +18,12 @@ boxer prep unboxer
|
|||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: construct-c-type ( class -- type )
|
||||
construct-empty
|
||||
int-regs >>reg-class ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
|
||||
\ c-type construct-c-type ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -181,10 +186,10 @@ DEFER: >c-ushort-array
|
|||
: define-c-type ( type name vocab -- )
|
||||
>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 construct-delegate ;
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type construct-c-type ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
|
|||
: define-from-array ( type vocab -- )
|
||||
[ 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 -- )
|
||||
"alien.c-types"
|
||||
[ define-c-type ] 2keep
|
||||
[ define-deref ] 2keep
|
||||
[ define-to-array ] 2keep
|
||||
[ define-from-array ] 2keep
|
||||
define-out ;
|
||||
{
|
||||
[ define-c-type ]
|
||||
[ define-deref ]
|
||||
[ define-to-array ]
|
||||
[ define-from-array ]
|
||||
[ define-out ]
|
||||
} 2cleave ;
|
||||
|
||||
: expand-constants ( c-type -- c-type' )
|
||||
#! 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 ;
|
||||
|
||||
[
|
||||
[ alien-cell ]
|
||||
[ set-alien-cell ]
|
||||
bootstrap-cell
|
||||
"box_alien"
|
||||
"alien_offset" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-cell ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_alien" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
"void*" define-primitive-type
|
||||
|
||||
[ alien-signed-8 ]
|
||||
[ set-alien-signed-8 ]
|
||||
8
|
||||
"box_signed_8"
|
||||
"to_signed_8" <primitive-type> <long-long-type>
|
||||
<long-long-type>
|
||||
[ alien-signed-8 ] >>getter
|
||||
[ set-alien-signed-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_signed_8" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
"longlong" define-primitive-type
|
||||
|
||||
[ alien-unsigned-8 ]
|
||||
[ set-alien-unsigned-8 ]
|
||||
8
|
||||
"box_unsigned_8"
|
||||
"to_unsigned_8" <primitive-type> <long-long-type>
|
||||
<long-long-type>
|
||||
[ alien-unsigned-8 ] >>getter
|
||||
[ set-alien-unsigned-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_unsigned_8" >>boxer
|
||||
"to_unsigned_8" >>unboxer
|
||||
"ulonglong" define-primitive-type
|
||||
|
||||
[ alien-signed-cell ]
|
||||
[ set-alien-signed-cell ]
|
||||
bootstrap-cell
|
||||
"box_signed_cell"
|
||||
"to_fixnum" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-signed-cell ] >>getter
|
||||
[ set-alien-signed-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_signed_cell" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"long" define-primitive-type
|
||||
|
||||
[ alien-unsigned-cell ]
|
||||
[ set-alien-unsigned-cell ]
|
||||
bootstrap-cell
|
||||
"box_unsigned_cell"
|
||||
"to_cell" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-unsigned-cell ] >>getter
|
||||
[ set-alien-unsigned-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_unsigned_cell" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"ulong" define-primitive-type
|
||||
|
||||
[ alien-signed-4 ]
|
||||
[ set-alien-signed-4 ]
|
||||
4
|
||||
"box_signed_4"
|
||||
"to_fixnum" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-signed-4 ] >>getter
|
||||
[ set-alien-signed-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_signed_4" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"int" define-primitive-type
|
||||
|
||||
[ alien-unsigned-4 ]
|
||||
[ set-alien-unsigned-4 ]
|
||||
4
|
||||
"box_unsigned_4"
|
||||
"to_cell" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-unsigned-4 ] >>getter
|
||||
[ set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_unsigned_4" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"uint" define-primitive-type
|
||||
|
||||
[ alien-signed-2 ]
|
||||
[ set-alien-signed-2 ]
|
||||
2
|
||||
"box_signed_2"
|
||||
"to_fixnum" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-signed-2 ] >>getter
|
||||
[ set-alien-signed-2 ] >>setter
|
||||
2 >>size
|
||||
2 >>align
|
||||
"box_signed_2" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"short" define-primitive-type
|
||||
|
||||
[ alien-unsigned-2 ]
|
||||
[ set-alien-unsigned-2 ]
|
||||
2
|
||||
"box_unsigned_2"
|
||||
"to_cell" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-unsigned-2 ] >>getter
|
||||
[ set-alien-unsigned-2 ] >>setter
|
||||
2 >>size
|
||||
2 >>align
|
||||
"box_unsigned_2" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"ushort" define-primitive-type
|
||||
|
||||
[ alien-signed-1 ]
|
||||
[ set-alien-signed-1 ]
|
||||
1
|
||||
"box_signed_1"
|
||||
"to_fixnum" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-signed-1 ] >>getter
|
||||
[ set-alien-signed-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_signed_1" >>boxer
|
||||
"to_fixnum" >>unboxer
|
||||
"char" define-primitive-type
|
||||
|
||||
[ alien-unsigned-1 ]
|
||||
[ set-alien-unsigned-1 ]
|
||||
1
|
||||
"box_unsigned_1"
|
||||
"to_cell" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-unsigned-1 ] >>getter
|
||||
[ set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_unsigned_1" >>boxer
|
||||
"to_cell" >>unboxer
|
||||
"uchar" define-primitive-type
|
||||
|
||||
[ alien-unsigned-4 zero? not ]
|
||||
[ 1 0 ? set-alien-unsigned-4 ]
|
||||
4
|
||||
"box_boolean"
|
||||
"to_boolean" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-unsigned-4 zero? not ] >>getter
|
||||
[ 1 0 ? set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" define-primitive-type
|
||||
|
||||
[ alien-float ]
|
||||
[ >r >r >float r> r> set-alien-float ]
|
||||
4
|
||||
"box_float"
|
||||
"to_float" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-float ] >>getter
|
||||
[ >r >r >float r> r> set-alien-float ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_float" >>boxer
|
||||
"to_float" >>unboxer
|
||||
single-float-regs >>reg-class
|
||||
[ >float ] >>prep
|
||||
"float" define-primitive-type
|
||||
|
||||
T{ float-regs f 4 } "float" c-type set-c-type-reg-class
|
||||
[ >float ] "float" c-type set-c-type-prep
|
||||
|
||||
[ alien-double ]
|
||||
[ >r >r >float r> r> set-alien-double ]
|
||||
8
|
||||
"box_double"
|
||||
"to_double" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-double ] >>getter
|
||||
[ >r >r >float r> r> set-alien-double ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
"box_double" >>boxer
|
||||
"to_double" >>unboxer
|
||||
double-float-regs >>reg-class
|
||||
[ >float ] >>prep
|
||||
"double" define-primitive-type
|
||||
|
||||
T{ float-regs f 8 } "double" c-type set-c-type-reg-class
|
||||
[ >float ] "double" c-type set-c-type-prep
|
||||
|
||||
[ alien-cell alien>char-string ]
|
||||
[ set-alien-cell ]
|
||||
bootstrap-cell
|
||||
"box_char_string"
|
||||
"alien_offset" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-cell alien>char-string ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
bootstrap-cell >>size
|
||||
bootstrap-cell >>align
|
||||
"box_char_string" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
[ string>char-alien ] >>prep
|
||||
"char*" define-primitive-type
|
||||
|
||||
"char*" "uchar*" typedef
|
||||
|
||||
[ string>char-alien ] "char*" c-type set-c-type-prep
|
||||
|
||||
[ alien-cell alien>u16-string ]
|
||||
[ set-alien-cell ]
|
||||
4
|
||||
"box_u16_string"
|
||||
"alien_offset" <primitive-type>
|
||||
<c-type>
|
||||
[ alien-cell alien>u16-string ] >>getter
|
||||
[ set-alien-cell ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_u16_string" >>boxer
|
||||
"alien_offset" >>unboxer
|
||||
[ string>u16-alien ] >>prep
|
||||
"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
|
||||
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -70,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
|
|||
|
||||
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 -- )
|
||||
|
||||
: (inc-reg-class)
|
||||
dup class inc
|
||||
M: reg-class inc-reg-class
|
||||
dup reg-class-variable inc
|
||||
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
|
||||
M: int-regs inc-reg-class
|
||||
(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 ;
|
||||
|
||||
: 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 )
|
||||
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 )
|
||||
[ dup class get swap inc-reg-class ] keep ;
|
||||
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
|
||||
|
||||
: alloc-parameter ( parameter -- reg reg-class )
|
||||
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." ;
|
||||
|
||||
: callback-bottom ( node -- )
|
||||
alien-callback-xt [ word-xt drop <alien> ] curry
|
||||
xt>> [ word-xt drop <alien> ] curry
|
||||
recursive-state get infer-quot ;
|
||||
|
||||
\ alien-callback [
|
||||
|
|
@ -373,8 +380,7 @@ TUPLE: callback-context ;
|
|||
|
||||
: wrap-callback-quot ( node -- quot )
|
||||
[
|
||||
dup alien-callback-quot
|
||||
swap prepare-callback-return append ,
|
||||
[ quot>> ] [ prepare-callback-return ] bi append ,
|
||||
[ callback-context construct-empty do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
|
|
@ -395,7 +401,7 @@ TUPLE: callback-context ;
|
|||
callback-unwind %unwind ;
|
||||
|
||||
: generate-callback ( node -- )
|
||||
dup alien-callback-xt dup [
|
||||
dup xt>> dup [
|
||||
init-templates
|
||||
%save-word-xt
|
||||
%prologue-later
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] [ [ no-tuple-class? ] is? ] must-fail-with
|
||||
] [ error>> no-tuple-class? ] must-fail-with
|
||||
|
||||
! Inheritance
|
||||
TUPLE: computer cpu ram ;
|
||||
|
|
@ -488,7 +488,7 @@ USE: vocabs
|
|||
] with-compilation-unit
|
||||
] 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...
|
||||
[ [ ] ] [
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: compiler generator generator.registers
|
|||
generator.registers.private tools.test namespaces sequences
|
||||
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
|
||||
|
|
@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
|
|||
|
||||
[ ] [ 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 ] [
|
||||
[
|
||||
copy-templates
|
||||
1 <int-vreg> phantom-push
|
||||
compute-free-vregs
|
||||
1 <int-vreg> T{ int-regs } free-vregs member?
|
||||
1 <int-vreg> int-regs free-vregs member?
|
||||
] with-scope
|
||||
] 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
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -202,3 +202,47 @@ TUPLE: my-tuple ;
|
|||
] [ 2drop no-case ] if
|
||||
] compile-call
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ byte-arrays bit-arrays float-arrays combinators words ;
|
|||
IN: cpu.architecture
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
TUPLE: stack-params ;
|
||||
SINGLETON: stack-params
|
||||
|
||||
! Return values of this class go here
|
||||
GENERIC: return-reg ( register-class -- reg )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@ M: x86.32 %box ( n reg-class func -- )
|
|||
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
|
||||
#! boxing a parameter being passed to a callback from C.
|
||||
[
|
||||
T{ int-regs } box@
|
||||
int-regs box@
|
||||
EDX over stack@ MOV
|
||||
EAX swap cell - stack@ MOV
|
||||
] when*
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ M: x86.64 %unbox ( n reg-class func -- )
|
|||
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.64 %unbox-long-long ( n func -- )
|
||||
T{ int-regs } swap %unbox ;
|
||||
int-regs swap %unbox ;
|
||||
|
||||
M: x86.64 %unbox-struct-1 ( -- )
|
||||
#! Alien must be in RDI.
|
||||
|
|
@ -103,7 +103,7 @@ M: x86.64 %box ( n reg-class func -- )
|
|||
f %alien-invoke ;
|
||||
|
||||
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 <= ;
|
||||
|
||||
|
|
@ -170,7 +170,7 @@ USE: cpu.x86.intrinsics
|
|||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "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-type-fields [
|
||||
|
|
@ -192,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq )
|
|||
] [
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
T{ int-regs } swap member?
|
||||
int-regs swap member?
|
||||
"void*" "double" ? c-type ,
|
||||
] each
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
USING: alien alien.c-types alien.compiler arrays
|
||||
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 %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 %load-param-reg >r swap stack@ r> MOVSS/D ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs classes classes.private classes.algebra
|
||||
combinators cpu.architecture generator.fixup hashtables kernel
|
||||
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
|
||||
|
||||
SYMBOL: +input+
|
||||
|
|
@ -13,9 +14,11 @@ SYMBOL: +clobber+
|
|||
SYMBOL: known-tag
|
||||
|
||||
! Register classes
|
||||
TUPLE: int-regs ;
|
||||
|
||||
TUPLE: float-regs size ;
|
||||
SINGLETON: int-regs
|
||||
SINGLETON: single-float-regs
|
||||
SINGLETON: double-float-regs
|
||||
UNION: float-regs single-float-regs double-float-regs ;
|
||||
UNION: reg-class int-regs float-regs ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
|
|||
M: value lazy-store 2drop ;
|
||||
|
||||
! A scratch register for computations
|
||||
TUPLE: vreg n ;
|
||||
TUPLE: vreg n reg-class ;
|
||||
|
||||
: <vreg> ( n reg-class -- vreg )
|
||||
{ set-vreg-n set-delegate } vreg construct ;
|
||||
C: <vreg> vreg ( n reg-class -- vreg )
|
||||
|
||||
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 move-spec reg-class>> move-spec ;
|
||||
|
||||
INSTANCE: vreg value
|
||||
|
||||
|
|
@ -62,9 +65,9 @@ M: float-regs move-spec drop float ;
|
|||
M: float-regs operand-class* drop float ;
|
||||
|
||||
! 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 ;
|
||||
|
||||
|
|
@ -73,7 +76,7 @@ INSTANCE: temp-reg value
|
|||
! A data stack location.
|
||||
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 operand-class* ds-loc-class ;
|
||||
|
|
@ -84,8 +87,7 @@ M: ds-loc live-loc?
|
|||
! A retain stack location.
|
||||
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 set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
|
|
@ -126,7 +128,7 @@ INSTANCE: cached value
|
|||
TUPLE: tagged vreg class ;
|
||||
|
||||
: <tagged> ( vreg -- tagged )
|
||||
{ set-tagged-vreg } tagged construct ;
|
||||
f tagged construct-boa ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
|
|
@ -340,8 +342,7 @@ SYMBOL: fresh-objects
|
|||
|
||||
! Computing free registers and initializing allocator
|
||||
: reg-spec>class ( spec -- class )
|
||||
float eq?
|
||||
T{ float-regs f 8 } T{ int-regs } ? ;
|
||||
float eq? double-float-regs int-regs ? ;
|
||||
|
||||
: free-vregs ( reg-class -- seq )
|
||||
#! Free vregs in a given register class
|
||||
|
|
@ -393,7 +394,7 @@ M: value (lazy-load)
|
|||
: compute-free-vregs ( -- )
|
||||
#! Create a new hashtable for thee free-vregs variable.
|
||||
live-vregs
|
||||
{ T{ int-regs } T{ float-regs f 8 } }
|
||||
{ int-regs double-float-regs }
|
||||
[ 2dup (compute-free-vregs) ] H{ } map>assoc
|
||||
\ free-vregs set
|
||||
drop ;
|
||||
|
|
@ -442,7 +443,7 @@ M: loc lazy-store
|
|||
: fast-shuffle? ( live-locs -- ? )
|
||||
#! Test if we have enough free registers to load all
|
||||
#! shuffle inputs at once.
|
||||
T{ int-regs } free-vregs [ length ] bi@ <= ;
|
||||
int-regs free-vregs [ length ] bi@ <= ;
|
||||
|
||||
: finalize-locs ( -- )
|
||||
#! Perform any deferred stack shuffling.
|
||||
|
|
@ -483,8 +484,8 @@ M: loc lazy-store
|
|||
|
||||
! Loading stacks to vregs
|
||||
: free-vregs? ( int# float# -- ? )
|
||||
T{ float-regs f 8 } free-vregs length <=
|
||||
>r T{ int-regs } free-vregs length <= r> and ;
|
||||
double-float-regs free-vregs length <=
|
||||
>r int-regs free-vregs length <= r> and ;
|
||||
|
||||
: phantom&spec ( phantom spec -- phantom' spec' )
|
||||
[ length f pad-left ] keep
|
||||
|
|
@ -534,7 +535,7 @@ M: loc lazy-store
|
|||
|
||||
: count-input-vregs ( phantom spec -- )
|
||||
phantom&spec [
|
||||
>r dup cached? [ cached-vreg ] when r> allocation
|
||||
>r dup cached? [ cached-vreg ] when r> first allocation
|
||||
] 2map count-vregs ;
|
||||
|
||||
: count-scratch-regs ( spec -- )
|
||||
|
|
@ -542,13 +543,13 @@ M: loc lazy-store
|
|||
|
||||
: guess-vregs ( dinput rinput scratch -- int# float# )
|
||||
H{
|
||||
{ T{ int-regs } 0 }
|
||||
{ T{ float-regs 8 } 0 }
|
||||
{ int-regs 0 }
|
||||
{ double-float-regs 0 }
|
||||
} clone [
|
||||
count-scratch-regs
|
||||
phantom-r 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 ;
|
||||
|
||||
: alloc-scratch ( -- )
|
||||
|
|
@ -581,12 +582,6 @@ M: loc lazy-store
|
|||
2drop t
|
||||
] 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-tags dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -217,9 +217,7 @@ $nl
|
|||
{ $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."
|
||||
{ $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* } "."
|
||||
$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 } "." ;
|
||||
"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* } "." ;
|
||||
|
||||
ARTICLE: "conditionals" "Conditionals and logic"
|
||||
"The basic conditionals:"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
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
|
||||
|
||||
TUPLE: testing x y z ;
|
||||
|
|
|
|||
|
|
@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * )
|
|||
[ breakage ] must-fail
|
||||
|
||||
! 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 )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
|
|||
io.streams.string namespaces classes effects source-files
|
||||
assocs sequences strings io.files definitions continuations
|
||||
sorting classes.tuple compiler.units debugger vocabs
|
||||
vocabs.loader ;
|
||||
vocabs.loader accessors ;
|
||||
IN: parser.tests
|
||||
|
||||
[
|
||||
|
|
@ -297,12 +297,12 @@ IN: parser.tests
|
|||
[
|
||||
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
|
||||
<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 ;"
|
||||
<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"
|
||||
|
|
@ -312,7 +312,7 @@ IN: parser.tests
|
|||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
|
||||
<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 ;"
|
||||
|
|
@ -322,7 +322,7 @@ IN: parser.tests
|
|||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<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"
|
||||
|
|
@ -332,12 +332,12 @@ IN: parser.tests
|
|||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<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 ;"
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -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: } } "." } ;
|
||||
|
||||
HELP: T{
|
||||
{ $syntax "T{ class delegate slots... }" }
|
||||
{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } }
|
||||
{ $syntax "T{ class slots... }" }
|
||||
{ $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: } } "."
|
||||
$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." } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: vocabs.loader.tests
|
|||
USING: vocabs.loader tools.test continuations vocabs math
|
||||
kernel arrays sequences namespaces io.streams.string
|
||||
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...
|
||||
[ ] [
|
||||
|
|
@ -68,7 +68,7 @@ IN: vocabs.loader.tests
|
|||
<string-reader>
|
||||
"resource:core/vocabs/loader/test/a/a.factor"
|
||||
parse-stream
|
||||
] [ [ no-word-error? ] is? ] must-fail-with
|
||||
] [ error>> error>> no-word-error? ] must-fail-with
|
||||
|
||||
0 "count-me" set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: arrays generic assocs kernel math namespaces
|
||||
sequences tools.test words definitions parser quotations
|
||||
vocabs continuations classes.tuple compiler.units
|
||||
io.streams.string ;
|
||||
io.streams.string accessors ;
|
||||
IN: words.tests
|
||||
|
||||
[ 4 ] [
|
||||
|
|
@ -147,7 +147,7 @@ SYMBOL: quot-uses-b
|
|||
] when*
|
||||
|
||||
[ "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
|
||||
|
|
|
|||
Loading…
Reference in New Issue