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

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

db4
Doug Coleman 2008-09-17 00:54:26 -05:00
parent 165e5b7ff8 6cad2e02e4
commit 87946d423d
21 changed files with 2134 additions and 367 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/compiler/constants/constants.factor
View File

@ -23,3 +23,30 @@ IN: compiler.constants
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
[ rc-absolute-cell = ]
[ rc-absolute = ]
tri or or ;

221
unfinished/compiler/backend/backend.factor
View File

@ -1,10 +1,223 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system ;
USING: accessors assocs arrays generic kernel kernel.private
math memory namespaces make sequences layouts system hashtables
classes alien byte-arrays combinators words sets classes.algebra
compiler.cfg.registers compiler.cfg.instructions ;
IN: compiler.backend
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( size -- ? )
! Labels
TUPLE: label offset ;
: <label> ( -- label ) label new ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
! Sequence of registers used for parameter passing in class
GENERIC: param-regs ( register-class -- regs )
GENERIC: param-reg ( n register-class -- reg )
M: object param-reg param-regs nth ;
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
! Call another word
HOOK: %call cpu ( word -- )
! Local jump for branches
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-f cpu ( label vreg -- )
! Test if vreg is 't' or not
HOOK: %jump-t cpu ( label vreg -- )
HOOK: %dispatch cpu ( -- )
HOOK: %dispatch-label cpu ( word -- )
! Return to caller
HOOK: %return cpu ( -- )
! Change datastack height
HOOK: %inc-d cpu ( n -- )
! Change callstack height
HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
HOOK: %replace cpu ( vreg loc -- )
! Copy values between vregs
HOOK: %copy cpu ( dst src -- )
HOOK: %copy-float cpu ( dst src -- )
! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass explode value structs?
HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
HOOK: fp-shadows-int? cpu ( -- ? )
HOOK: %prepare-unbox cpu ( -- )
HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct cpu ( c-type -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
HOOK: %box cpu ( n reg-class func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( c-type -- )
HOOK: %box-large-struct cpu ( n c-type -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( alien-node -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
HOOK: %unwind cpu ( n -- )
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
GENERIC: v>operand ( obj -- operand )
SYMBOL: registers
M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
M: object load-literal v>operand load-indirect ;
PREDICATE: small-slot < integer cells small-enough? ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip
[ [ nip ] prepose ] dip if ;
inline
: %unbox-struct ( n c-type -- )
[
%unbox-small-struct
] [
%unbox-large-struct
] if-small-struct ;
: %box-struct ( n c-type -- )
[
%box-small-struct
] [
%box-large-struct
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array cpu ( dst src -- )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu ( -- )
SYMBOL: operands
: init-intrinsic ( insn -- )
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
: (operand) ( name -- operand )
operands get at* [ "Bad operand name" throw ] unless ;
: operand ( name -- operand )
(operand) v>operand ;
: operand-class ( var -- class )
(operand) value-class ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline

313
unfinished/compiler/backend/x86/32/32.factor
View File

@ -1,11 +1,318 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers
compiler.backend ;
USING: alien.c-types arrays kernel kernel.private math
namespaces sequences stack-checker.known-words system layouts
combinators command-line io vocabs.loader accessors init
compiler compiler.units compiler.constants compiler.codegen
compiler.cfg.builder compiler.alien compiler.codegen.fixup
cpu.x86 compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs push-return-reg return-reg PUSH ;
: load/store-int-return ( n reg-class -- src dst )
return-reg stack-reg rot [+] ;
M: int-regs load-return-reg load/store-int-return MOV ;
M: int-regs store-return-reg load/store-int-return swap MOV ;
M: float-regs param-regs drop { } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
: load/store-float-return ( n reg-class -- op size )
[ stack@ ] [ reg-size ] bi* ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
: align-sub ( n -- )
dup 16 align swap - ESP swap SUB ;
: align-add ( n -- )
16 align ESP swap ADD ;
: with-aligned-stack ( n quot -- )
swap dup align-sub slip align-add ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
: box@ ( n reg-class -- stack@ )
#! Used for callbacks; we want to box the values given to
#! us by the C function caller. Computes stack location of
#! nth parameter; note that we must go back one more stack
#! frame, since %box sets one up to call the one-arg boxer
#! function. The size of this stack frame so far depends on
#! the reg-class of the boxer's arg.
reg-size neg + stack-frame* + 20 + ;
: (%box) ( n reg-class -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
: (%box-long-long) ( n -- )
#! If n is f, push the return registers onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
EDX PUSH
EAX PUSH ;
M: x86.32 %box-long-long ( n func -- )
8 [
[ (%box-long-long) ] [ f %alien-invoke ] bi*
] with-aligned-stack ;
: struct-return@ ( size n -- n )
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
M: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
heap-size
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
8 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 [
heap-size PUSH
EDX PUSH
EAX PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
#! Alien must be in EAX.
heap-size
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
%prepare-unbox
EAX PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Place top of data stack in EAX
EAX POP
! Restore C stack
ESP 12 ADD
! Unbox EAX
unbox-return ;
M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
#! b) If we just called a function returning a struct, we
#! have to fix ESP.
{
{
[ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
}
[ drop ]
} cond ;
M: x86.32 %unwind ( n -- ) RET ;
os windows? [
cell "longlong" c-type (>>align)
cell "ulonglong" c-type (>>align)
4 "double" c-type (>>align)
] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ;
<<
\ (sse2?) [
{ EAX EBX ECX EDX } [ PUSH ] each
EAX 1 MOV
CPUID
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
JE
] { } define-if-intrinsic
\ (sse2?) { } { object } define-primitive
>>
: sse2? ( -- ? ) (sse2?) ;
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ optimized-recompile-hook ] recompile-hook [
[ sse2? ] compile-call
] with-variable
[
" - yes" print
"compiler.backend.x86.sse2" require
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
"You will need to bootstrap Factor again." print
flush
1 exit
] unless
] "compiler.backend.x86" add-init-hook
] [
" - no" print
] if
] unless

218
unfinished/compiler/backend/x86/64/64.factor
View File

@ -1,7 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers
compiler.backend ;
USING: accessors alien.c-types arrays kernel kernel.private math
namespaces make sequences system layouts alien alien.accessors
alien.structs slots splitting assocs combinators
cpu.x86 compiler.codegen compiler.constants
compiler.codegen.fixup compiler.cfg.registers compiler.backend
compiler.backend.x86 compiler.backend.x86.sse2 ;
IN: compiler.backend.x86.64
M: x86.64 machine-registers
@ -12,3 +16,211 @@ M: x86.64 machine-registers
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: int-regs return-reg drop RAX ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs return-reg drop XMM0 ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
drop
>r R11 swap stack@ MOV
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- )
int-regs swap %unbox ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in RDI.
RDI swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Move alien_offset() return value to RDI so that we don't
! clobber it.
RDI RAX MOV
[
flatten-small-struct [ %unbox-struct-field ] each-index
] with-return-regs ;
M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in RDI
heap-size
! Load destination address
RSI RSP roll [+] LEA
! Load structure size
RDX swap MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
: load-return-value ( reg-class -- )
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
swap load-return-value
] if*
f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
{ int-regs [ int-regs get pop MOV ] }
{ double-float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct.
[
[ flatten-small-struct [ %box-struct-field ] each-index ]
[ RDX swap heap-size MOV ] bi
RDI 0 box-struct-field@ MOV
RSI 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( size n -- n )
[ ] [ \ stack-frame get swap - ] ?if ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
heap-size
RSI over MOV
! Compute destination address
swap struct-return@ RDI RSP rot [+] LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
cell temp@ RDI MOV
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
RDI cell temp@ MOV
! Unbox former top of data stack to return registers
unbox-return ;
M: x86.64 %cleanup ( alien-node -- ) drop ;
M: x86.64 %unwind ( n -- ) drop 0 RET ;
USE: cpu.x86.intrinsics
! On 64-bit systems, the result of reading 4 bytes from memory
! is a fixnum.
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
\ set-alien-unsigned-4 small-reg-32 define-setter
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter

110
unfinished/compiler/backend/x86/sse2/sse2.factor Normal file
View File

@ -0,0 +1,110 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays generic kernel system
kernel.private math math.private memory namespaces sequences
words math.floats.private layouts quotations cpu.x86
compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
compiler.constants compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.sse2
M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
8 (object@) swap v>operand MOVSD
float %store-tagged
] %allot ;
M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
: define-float-op ( word op -- )
[ "x" operand "y" operand ] swap suffix T{ template
{ input { { float "x" } { float "y" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic ;
{
{ float+ ADDSD }
{ float- SUBSD }
{ float* MULSD }
{ float/f DIVSD }
} [
first2 define-float-op
] each
: define-float-jump ( word op -- )
[ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< JAE }
{ float<= JA }
{ float> JBE }
{ float>= JB }
{ float= JNE }
} [
first2 define-float-jump
] each
\ float>fixnum [
"out" operand "in" operand CVTTSD2SI
"out" operand tag-bits get SHL
] T{ template
{ input { { float "in" } } }
{ scratch { { f "out" } } }
{ output { "out" } }
} define-intrinsic
\ fixnum>float [
"in" operand %untag-fixnum
"out" operand "in" operand CVTSI2SD
] T{ template
{ input { { f "in" } } }
{ scratch { { float "out" } } }
{ output { "out" } }
{ clobber { "in" } }
{ gc t }
} define-intrinsic
: alien-float-get-template
T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { float "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} ;
: alien-float-set-template
T{ template
{ input {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "offset" } }
} ;
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
[ "value" operand swap %alien-accessor ] curry
alien-float-set-template
define-intrinsic
[ "value" operand swap %alien-accessor ] curry
alien-float-get-template
define-intrinsic ;
\ alien-double
[ MOVSD ]
\ set-alien-double
[ swap MOVSD ]
define-alien-float-intrinsics
\ alien-float
[ dupd MOVSS dup CVTSS2SD ]
\ set-alien-float
[ swap dup dup CVTSD2SS MOVSS ]
define-alien-float-intrinsics

755
unfinished/compiler/backend/x86/x86.factor Normal file
View File

@ -0,0 +1,755 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays alien.accessors
compiler.backend kernel kernel.private math memory namespaces
make sequences words system layouts combinators math.order
math.private alien alien.c-types slots.private cpu.x86
cpu.x86.private compiler.backend compiler.codegen.fixup
compiler.constants compiler.intrinsics compiler.cfg.builder
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.templates ;
IN: compiler.backend.x86
M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
M: word JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: word CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: word JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
HOOK: stack-save-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: rs-loc v>operand 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 ;
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 ;
GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )
M: f load-literal
v>operand \ f tag-number MOV drop ;
M: fixnum load-literal
v>operand swap tag-fixnum MOV ;
M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
: factor-area-size ( -- n ) 4 cells ;
M: x86 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this
dup cell + PUSH
temp-reg-1 PUSH
stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
HOOK: %alien-global cpu ( symbol dll register -- )
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
"stack_chain" f temp-reg-1 %alien-global
temp-reg-1 [] stack-reg MOV
temp-reg-1 [] cell SUB
temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
: align-code ( n -- )
0 <repetition> % ;
M: x86 %dispatch ( -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
temp-reg-1 fixnum>slot@
! Add jump table base
temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
temp-reg-1 temp-reg-2 ADD
temp-reg-1 HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86 %replace swap %peek ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86 value-structs? t ;
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
: %untag-fixnum ( reg -- ) tag-bits get SAR ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
rs-reg swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
rs-reg \ f tag-number CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD
! Now recurse on the underlying alien
rs-reg rs-reg underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
ds-reg rs-reg ADD
! Add an offset to start of byte array's data
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
ds-reg POP ;
: allot-reg ( -- reg )
#! We temporarily use the datastack register, since it won't
#! be accessed inside the quotation given to %allot in any
#! case.
ds-reg ;
: (object@) ( n -- operand ) allot-reg swap [+] ;
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
: inc-allot-ptr ( n -- )
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;
: %allot ( header size quot -- )
allot-reg PUSH
swap >r >r
load-allot-ptr
store-header
r> call
r> inc-allot-ptr
allot-reg POP ; inline
: fresh-object drop ;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand r>
allot-reg swap tag-number OR
allot-reg MOV ;
: %allot-bignum-signed-1 ( outreg inreg -- )
#! on entry, inreg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in outreg
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
{ "end" "nonzero" "positive" "store" }
[ define-label ] each
dup v>operand 0 CMP ! is it zero?
"nonzero" get JNE
0 >bignum pick v>operand load-indirect ! this is our result
"end" get JMP
"nonzero" resolve-label
bignum 4 cells [
! Write length
1 object@ 2 v>operand MOV
! Test sign
dup v>operand 0 CMP
"positive" get JGE
2 object@ 1 MOV ! negative sign
dup v>operand NEG
"store" get JMP
"positive" resolve-label
2 object@ 0 MOV ! positive sign
"store" resolve-label
3 object@ swap v>operand MOV
! Store tagged ptr in reg
bignum %store-tagged
] %allot
"end" resolve-label
] with-scope ;
M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
"f" get JE
alien 4 cells [
1 object@ \ f tag-number MOV
2 object@ \ f tag-number MOV
! Store src in alien-offset slot
3 object@ swap v>operand MOV
! Store tagged ptr in dst
dup object %store-tagged
] %allot
"end" get JMP
"f" resolve-label
f [ v>operand ] bi@ MOV
"end" resolve-label
] with-scope ;
! Type checks
\ tag [
"in" operand tag-mask get AND
"in" operand %tag-fixnum
] T{ template
{ input { { f "in" } } }
{ output { "in" } }
} define-intrinsic
! Slots
: %slot-literal-known-tag ( -- op )
"obj" operand
"n" get cells
"obj" operand-tag - [+] ;
: %slot-literal-any-tag ( -- op )
"obj" operand %untag
"obj" operand "n" get cells [+] ;
: %slot-any ( -- op )
"obj" operand %untag
"n" operand fixnum>slot@
"obj" operand "n" operand [+] ;
\ slot {
! Slot number is literal and the tag is known
{
[ "val" operand %slot-literal-known-tag MOV ] T{ template
{ input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ scratch { { f "val" } } }
{ output { "val" } }
}
}
! Slot number is literal
{
[ "obj" operand %slot-literal-any-tag MOV ] T{ template
{ input { { f "obj" } { [ small-slot? ] "n" } } }
{ output { "obj" } }
}
}
! Slot number in a register
{
[ "obj" operand %slot-any MOV ] T{ template
{ input { { f "obj" } { f "n" } } }
{ output { "obj" } }
{ clobber { "n" } }
}
}
} define-intrinsics
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" operand-immediate? "obj" fresh-object? or [
! Mark the card
"obj" operand card-bits SHR
"cards_offset" f "scratch" operand %alien-global
"scratch" operand "obj" operand [+] card-mark <byte> MOV
! Mark the card deck
"obj" operand deck-bits card-bits - SHR
"decks_offset" f "scratch" operand %alien-global
"scratch" operand "obj" operand [+] card-mark <byte> MOV
] unless ;
\ set-slot {
! Slot number is literal and the tag is known
{
[ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" } }
}
}
! Slot number is literal
{
[ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" } }
}
}
! Slot number in a register
{
[ %slot-any "val" operand MOV generate-write-barrier ] T{ template
{ input { { f "val" } { f "obj" } { f "n" } } }
{ scratch { { f "scratch" } } }
{ clobber { "obj" "n" } }
}
}
} define-intrinsics
! Sometimes, we need to do stuff with operands which are
! less than the word size. Instead of teaching the register
! allocator about the different sized registers, with all
! the complexity this entails, we just push/pop a register
! which is guaranteed to be unused (the tempreg)
: small-reg cell 8 = RBX EBX ? ; inline
: small-reg-8 BL ; inline
: small-reg-16 BX ; inline
: small-reg-32 EBX ; inline
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ output { "x" } }
} fixnum-op ;
: fixnum-register-op ( op -- pair )
T{ template
{ input { { f "x" } { f "y" } } }
{ output { "x" } }
} fixnum-op ;
: define-fixnum-op ( word op -- )
[ fixnum-value-op ] keep fixnum-register-op
2array define-intrinsics ;
{
{ fixnum+fast ADD }
{ fixnum-fast SUB }
{ fixnum-bitand AND }
{ fixnum-bitor OR }
{ fixnum-bitxor XOR }
} [
first2 define-fixnum-op
] each
\ fixnum-bitnot [
"x" operand NOT
"x" operand tag-mask get XOR
] T{ template
{ input { { f "x" } } }
{ output { "x" } }
} define-intrinsic
\ fixnum*fast {
{
[
"x" operand "y" get IMUL2
] T{ template
{ input { { f "x" } { [ small-tagged? ] "y" } } }
{ output { "x" } }
}
} {
[
"out" operand "x" operand MOV
"out" operand %untag-fixnum
"y" operand "out" operand IMUL2
] T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "out" } } }
{ output { "out" } }
}
}
} define-intrinsics
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
\ fixnum-shift-fast [
"x" operand "y" get
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits
"x" operand %untag
] T{ template
{ input { { f "x" } { [ ] "y" } } }
{ output { "x" } }
} define-intrinsic
: overflow-check ( word -- )
"end" define-label
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! turn the result into a bignum and leave it in EAX.
"end" get JNO
! There was an overflow. Recompute the original operand.
{ "y" "x" } %untag-fixnums
"x" operand "y" operand rot execute
"z" get "x" get %allot-bignum-signed-1
"end" resolve-label ; inline
: overflow-template ( word insn -- )
[ overflow-check ] curry T{ template
{ input { { f "x" } { f "y" } } }
{ scratch { { f "z" } } }
{ output { "z" } }
{ clobber { "x" "y" } }
{ gc t }
} define-intrinsic ;
\ fixnum+ \ ADD overflow-template
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
: fixnum-register-jump ( op -- pair )
{ { f "x" } { f "y" } } fixnum-jump ;
: define-fixnum-jump ( word op -- )
[ fixnum-value-jump ] keep fixnum-register-jump
2array define-if-intrinsics ;
{
{ fixnum< JL }
{ fixnum<= JLE }
{ fixnum> JG }
{ fixnum>= JGE }
{ eq? JE }
} [
first2 define-fixnum-jump
] each
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" get dup %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ output { "x" } }
{ gc t }
} define-intrinsic
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label
"end" define-label
"x" operand %untag
"y" operand "x" operand cell [+] MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
"y" operand 1 v>operand CMP
"nonzero" get JNE
"y" operand 0 MOV
"end" get JMP
"nonzero" resolve-label
! load the value
"y" operand "x" operand 3 cells [+] MOV
! load the sign
"x" operand "x" operand 2 cells [+] MOV
! is the sign negative?
"x" operand 0 CMP
"positive" get JE
"y" operand -1 IMUL2
"positive" resolve-label
"y" operand 3 SHL
"end" resolve-label
] T{ template
{ input { { f "x" } } }
{ scratch { { f "y" } } }
{ clobber { "x" } }
{ output { "y" } }
} define-intrinsic
! User environment
: %userenv ( -- )
"x" operand 0 MOV
"userenv" f rc-absolute-cell rel-dlsym
"n" operand fixnum>slot@
"n" operand "x" operand ADD ;
\ getenv [
%userenv "n" operand dup [] MOV
] T{ template
{ input { { f "n" } } }
{ scratch { { f "x" } } }
{ output { "n" } }
} define-intrinsic
\ setenv [
%userenv "n" operand [] "val" operand MOV
] T{ template
{ input { { f "val" } { f "n" } } }
{ scratch { { f "x" } } }
{ clobber { "n" } }
} define-intrinsic
\ (tuple) [
tuple "layout" get size>> 2 + cells [
! Store layout
"layout" get "scratch" operand load-indirect
1 object@ "scratch" operand MOV
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
] T{ template
{ input { { [ ] "layout" } } }
{ scratch { { f "tuple" } { f "scratch" } } }
{ output { "tuple" } }
{ gc t }
} define-intrinsic
\ (array) [
array "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] T{ template
{ input { { [ ] "n" } } }
{ scratch { { f "array" } } }
{ output { "array" } }
{ gc t }
} define-intrinsic
\ (byte-array) [
byte-array "n" get 2 cells + [
! Store length
1 object@ "n" operand MOV
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] T{ template
{ input { { [ ] "n" } } }
{ scratch { { f "array" } } }
{ output { "array" } }
{ gc t }
} define-intrinsic
\ <ratio> [
ratio 3 cells [
1 object@ "numerator" operand MOV
2 object@ "denominator" operand MOV
! Store tagged ptr in reg
"ratio" get ratio %store-tagged
] %allot
] T{ template
{ input { { f "numerator" } { f "denominator" } } }
{ scratch { { f "ratio" } } }
{ output { "ratio" } }
{ gc t }
} define-intrinsic
\ <complex> [
complex 3 cells [
1 object@ "real" operand MOV
2 object@ "imaginary" operand MOV
! Store tagged ptr in reg
"complex" get complex %store-tagged
] %allot
] T{ template
{ input { { f "real" } { f "imaginary" } } }
{ scratch { { f "complex" } } }
{ output { "complex" } }
{ gc t }
} define-intrinsic
\ <wrapper> [
wrapper 2 cells [
1 object@ "obj" operand MOV
! Store tagged ptr in reg
"wrapper" get object %store-tagged
] %allot
] T{ template
{ input { { f "obj" } } }
{ scratch { { f "wrapper" } } }
{ output { "wrapper" } }
{ gc t }
} define-intrinsic
! Alien intrinsics
: %alien-accessor ( quot -- )
"offset" operand %untag-fixnum
"offset" operand "alien" operand ADD
"offset" operand [] swap call ; inline
: %alien-integer-get ( quot reg -- )
small-reg PUSH
swap %alien-accessor
"value" operand small-reg MOV
"value" operand %tag-fixnum
small-reg POP ; inline
: alien-integer-get-template
T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { f "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} ;
: define-getter ( word quot reg -- )
[ %alien-integer-get ] 2curry
alien-integer-get-template
define-intrinsic ;
: define-unsigned-getter ( word reg -- )
[ small-reg dup XOR MOV ] swap define-getter ;
: define-signed-getter ( word reg -- )
[ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
: %alien-integer-set ( quot reg -- )
small-reg PUSH
small-reg "value" operand MOV
small-reg %untag-fixnum
swap %alien-accessor
small-reg POP ; inline
: alien-integer-set-template
T{ template
{ input {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "value" "offset" } }
} ;
: define-setter ( word reg -- )
[ swap MOV ] swap
[ %alien-integer-set ] 2curry
alien-integer-set-template
define-intrinsic ;
\ alien-unsigned-1 small-reg-8 define-unsigned-getter
\ set-alien-unsigned-1 small-reg-8 define-setter
\ alien-signed-1 small-reg-8 define-signed-getter
\ set-alien-signed-1 small-reg-8 define-setter
\ alien-unsigned-2 small-reg-16 define-unsigned-getter
\ set-alien-unsigned-2 small-reg-16 define-setter
\ alien-signed-2 small-reg-16 define-signed-getter
\ set-alien-signed-2 small-reg-16 define-setter
\ alien-cell [
"value" operand [ MOV ] %alien-accessor
] T{ template
{ input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ scratch { { unboxed-alien "value" } } }
{ output { "value" } }
{ clobber { "offset" } }
} define-intrinsic
\ set-alien-cell [
"value" operand [ swap MOV ] %alien-accessor
] T{ template
{ input {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ clobber { "offset" } }
} define-intrinsic

109
unfinished/compiler/cfg/builder/builder.factor
View File

@ -32,18 +32,9 @@ IN: compiler.cfg.builder
: stop-iterating ( -- next ) end-basic-block f ;
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
! Basic block after prologue, makes recursion faster
@ -81,8 +72,8 @@ GENERIC: emit-node ( node -- next )
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
init-phantoms
%prologue
%branch
##prologue
##branch
begin-basic-block
current-label get remember-loop ;
@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
[ emit-nodes ] with-node-iterator
] with-cfg-builder ;
: build-cfg ( nodes word label -- procedures )
: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
(build-cfg)
dup (build-cfg)
] with-variable
] keep ;
SYMBOL: +intrinsics+
SYMBOL: +if-intrinsics+
: if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ;
word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next )
%branch
##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
finalize-phantoms
{
{ [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
{ [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ %epilogue %jump stop-iterating ]
[ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
@ -130,50 +124,52 @@ M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: emit-branch ( nodes -- final-bb )
[
: emit-branch ( obj quot -- final-bb )
'[
begin-basic-block copy-phantoms
emit-nodes
basic-block get dup [ %branch ] when
@
basic-block get dup [ ##branch ] when
] with-scope ;
: emit-if ( node -- next )
children>> [ emit-branch ] map
: emit-branches ( seq quot -- )
'[ _ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each
init-phantoms
iterate-next ;
init-phantoms ;
: emit-if ( node -- next )
children>> [ emit-nodes ] emit-branches ;
M: #if emit-node
{ { f "flag" } } lazy-load first %branch-t
emit-if ;
{ { f "flag" } } lazy-load first ##branch-t
emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
#! The order here is important, dispatch-branches must
#! run after ##dispatch, so that each branch gets the
#! correct register state
gensym [
[
copy-phantoms
%prologue
##prologue
[ emit-nodes ] with-node-iterator
%epilogue
%return
##epilogue
##return
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
%dispatch-label
##dispatch-label
] each ;
: emit-dispatch ( node -- )
%dispatch dispatch-branches init-phantoms ;
##epilogue ##dispatch dispatch-branches init-phantoms ;
M: #dispatch emit-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
emit-dispatch iterate-next
] [
@ -187,23 +183,23 @@ M: #dispatch emit-node
! #call
: define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ;
+intrinsics+ set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map
"if-intrinsics" set-word-prop ;
[ template new swap >>input ] assoc-map
+if-intrinsics+ set-word-prop ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f )
word>> "intrinsics" word-prop find-template ;
word>> +intrinsics+ word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f )
word>> "if-intrinsics" word-prop find-template ;
word>> +if-intrinsics+ word-prop find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
@ -213,21 +209,24 @@ M: #dispatch emit-node
} cond ;
: do-if-intrinsic ( pair -- next )
[ %if-intrinsic ] apply-template skip-next emit-if ;
[ ##if-intrinsic ] apply-template skip-next emit-if
iterate-next ;
: do-boolean-intrinsic ( pair -- next )
[
f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
] apply-template iterate-next ;
[ ##if-intrinsic ] apply-template
{ t f } [
<constant> phantom-push finalize-phantoms
] emit-branches
iterate-next ;
: do-intrinsic ( pair -- next )
[ %intrinsic ] apply-template iterate-next ;
[ ##intrinsic ] apply-template iterate-next ;
: setup-operand-classes ( #call -- )
node-input-infos [ class>> ] map set-operand-classes ;
: setup-value-classes ( #call -- )
node-input-infos [ class>> ] map set-value-classes ;
M: #call emit-node
dup setup-operand-classes
dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
@ -259,12 +258,12 @@ M: #r> emit-node
! #return
M: #return emit-node
drop finalize-phantoms %epilogue %return f ;
drop finalize-phantoms ##epilogue ##return f ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
[ %epilogue %return ] unless f ;
[ ##epilogue ##return ] unless f ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
! FFI
M: #alien-invoke emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-invoke iterate-next ]
[ alien-invoke-frame ##frame-required ]
[ ##alien-invoke iterate-next ]
bi ;
M: #alien-indirect emit-node
params>>
[ alien-invoke-frame %frame-required ]
[ %alien-indirect iterate-next ]
[ alien-invoke-frame ##frame-required ]
[ ##alien-indirect iterate-next ]
bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
[ init-phantoms %alien-callback ] with-cfg-builder
[ init-phantoms ##alien-callback ] with-cfg-builder
iterate-next ;
! No-op nodes

7
unfinished/compiler/cfg/cfg.factor
View File

@ -11,16 +11,13 @@ C: <cfg> cfg
TUPLE: basic-block < identity-tuple
visited
number
label
instructions
successors
predecessors ;
successors ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors ;
V{ } clone >>successors ;
TUPLE: mr instructions word label ;

5
unfinished/compiler/cfg/debugger/debugger.factor
View File

@ -9,11 +9,10 @@ IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
build-tree optimize-tree gensym gensym build-cfg ;
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep dup
build-cfg ;
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;

115
unfinished/compiler/cfg/instructions/instructions.factor
View File

@ -6,103 +6,102 @@ IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: %cond-branch < insn src ;
TUPLE: %unary < insn dst src ;
TUPLE: %nullary < insn dst ;
TUPLE: ##cond-branch < insn src ;
TUPLE: ##unary < insn dst src ;
TUPLE: ##nullary < insn dst ;
! Stack operations
INSN: %load-literal < %nullary obj ;
INSN: %peek < %nullary loc ;
INSN: %replace src loc ;
INSN: %inc-d n ;
INSN: %inc-r n ;
INSN: ##load-literal < ##nullary obj ;
INSN: ##peek < ##nullary loc ;
INSN: ##replace src loc ;
INSN: ##inc-d n ;
INSN: ##inc-r n ;
! Calling convention
INSN: %return ;
INSN: ##return ;
! Subroutine calls
INSN: %call word ;
INSN: %jump word ;
INSN: %intrinsic quot regs ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
INSN: %dispatch-label label ;
INSN: %dispatch ;
INSN: ##dispatch-label label ;
INSN: ##dispatch ;
! Boxing and unboxing
INSN: %copy < %unary ;
INSN: %copy-float < %unary ;
INSN: %unbox-float < %unary ;
INSN: %unbox-f < %unary ;
INSN: %unbox-alien < %unary ;
INSN: %unbox-byte-array < %unary ;
INSN: %unbox-any-c-ptr < %unary ;
INSN: %box-float < %unary ;
INSN: %box-alien < %unary ;
INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ;
INSN: ##box-float < ##unary ;
INSN: ##box-alien < ##unary ;
INSN: %gc ;
INSN: ##gc ;
! FFI
INSN: %alien-invoke params ;
INSN: %alien-indirect params ;
INSN: %alien-callback params ;
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
INSN: ##alien-callback params ;
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: %nullary defs-vregs dst>> >vreg 1array ;
M: %unary defs-vregs dst>> >vreg 1array ;
M: ##nullary defs-vregs dst>> >vreg 1array ;
M: ##unary defs-vregs dst>> >vreg 1array ;
M: insn defs-vregs drop f ;
M: %replace uses-vregs src>> >vreg 1array ;
M: %unary uses-vregs src>> >vreg 1array ;
M: ##replace uses-vregs src>> >vreg 1array ;
M: ##unary uses-vregs src>> >vreg 1array ;
M: insn uses-vregs drop f ;
! M: %intrinsic uses-vregs vregs>> values ;
: intrinsic-vregs ( assoc -- seq' )
[ nip >vreg ] { } assoc>map sift ;
: intrinsic-defs-vregs ( insn -- seq )
defs-vregs>> intrinsic-vregs ;
: intrinsic-uses-vregs ( insn -- seq )
uses-vregs>> intrinsic-vregs ;
M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by CFG IR only.
INSN: %prologue ;
INSN: %epilogue ;
INSN: %frame-required n ;
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##frame-required n ;
INSN: %branch ;
INSN: %branch-f < %cond-branch ;
INSN: %branch-t < %cond-branch ;
INSN: %if-intrinsic quot vregs ;
INSN: %boolean-intrinsic quot vregs dst ;
INSN: ##branch ;
INSN: ##branch-f < ##cond-branch ;
INSN: ##branch-t < ##cond-branch ;
INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
M: %cond-branch uses-vregs src>> 1array ;
M: ##cond-branch uses-vregs src>> >vreg 1array ;
! M: %if-intrinsic uses-vregs vregs>> values ;
M: %boolean-intrinsic defs-vregs dst>> 1array ;
! M: %boolean-intrinsic uses-vregs
! [ vregs>> values ] [ out>> ] bi suffix ;
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
INSN: _prologue n ;
INSN: _epilogue n ;
TUPLE: label id ;
INSN: _label label ;
: <label> ( -- label ) \ <label> counter label boa ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- )
dup label? [ get ] unless _label ;
INSN: _label id ;
TUPLE: _cond-branch < insn src label ;
INSN: _branch label ;
INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ;
INSN: _if-intrinsic label quot vregs ;
INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
M: _cond-branch uses-vregs src>> >vreg 1array ;
! M: _if-intrinsic uses-vregs vregs>> values ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
INSN: _spill src n ;
INSN: _reload dst n ;

5
unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -3,6 +3,7 @@ USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
compiler.cfg.registers
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.debugger ;
@ -98,3 +99,7 @@ SYMBOL: max-uses
[ ] [ 10 4 2 60 random-test ] unit-test
[ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 random-test ] unit-test
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test

13
unfinished/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -8,9 +8,20 @@ compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
! References:
! Linear Scan Register Allocation
! by Massimiliano Poletto and Vivek Sarkar
! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
! Linear Scan Register Allocation for the Java HotSpot Client Compiler
! by Christian Wimmer
! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
! Quality and Speed in Linear-scan Register Allocation
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: linear-scan ( mr -- mr' )
[
dup compute-live-intervals

1
unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -28,7 +28,6 @@ SYMBOL: live-intervals
at [ (>>end) ] [ uses>> push ] 2bi ;
: new-live-interval ( n vreg live-intervals -- )
2dup key? [ "Multiple defs" throw ] when
[ [ <live-interval> ] keep ] dip set-at ;
: compute-live-intervals* ( insn n -- )

42
unfinished/compiler/cfg/linearization/linearization.factor
View File

@ -12,7 +12,7 @@ IN: compiler.cfg.linearization
SYMBOL: frame-size
: compute-frame-size ( rpo -- )
[ instructions>> [ %frame-required? ] filter ] map concat
[ instructions>> [ ##frame-required? ] filter ] map concat
[ f ] [ [ n>> ] map supremum ] if-empty
frame-size set ;
@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
M: insn linearize-insn , drop ;
M: %frame-required linearize-insn 2drop ;
M: ##frame-required linearize-insn 2drop ;
M: %prologue linearize-insn
M: ##prologue linearize-insn
2drop frame-size get [ _prologue ] when* ;
M: %epilogue linearize-insn
M: ##epilogue linearize-insn
2drop frame-size get [ _epilogue ] when* ;
: useless-branch? ( basic-block successor -- ? )
@ -39,50 +39,40 @@ M: %epilogue linearize-insn
: branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned.
instructions>> dup length 2 = [
[ first %epilogue? ] [ second %return? ] bi and
[ first ##epilogue? ] [ second ##return? ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-return? ] [ nip linearize-insns ] }
[ nip label>> _branch ]
[ nip number>> _branch ]
} cond ;
M: %branch linearize-insn
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 )
dup successors>> first2 swap label>> ; inline
dup successors>> first2 swap number>> ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
[ conditional ] [ src>> ] bi* swap ; inline
M: %branch-f linearize-insn
M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ;
M: %branch-t linearize-insn
M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ;
M: %if-intrinsic linearize-insn
[ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
: >intrinsic< ( insn -- quot defs uses )
[ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
M: ##if-intrinsic linearize-insn
[ conditional ] [ >intrinsic< ] bi*
_if-intrinsic emit-branch ;
M: %boolean-intrinsic linearize-insn
[
"false" define-label
"end" define-label
"false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
dup dst>> t %load-literal
"end" get _branch
"false" resolve-label
dup dst>> f %load-literal
"end" resolve-label
] with-scope
2drop ;
: linearize-basic-block ( bb -- )
[ label>> _label ] [ linearize-insns ] bi ;
[ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;

22
unfinished/compiler/cfg/registers/registers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces math kernel ;
USING: accessors namespaces math kernel alien classes ;
IN: compiler.cfg.registers
! Virtual CPU registers, used by CFG and machine IRs
@ -8,8 +8,14 @@ IN: compiler.cfg.registers
MIXIN: value
GENERIC: >vreg ( obj -- vreg )
GENERIC: set-value-class ( class obj -- )
GENERIC: value-class* ( operand -- class )
: value-class ( operand -- class ) value-class* object or ;
M: value >vreg drop f ;
M: value set-value-class 2drop ;
M: value value-class* drop f ;
! Register classes
SINGLETON: int-regs
@ -47,6 +53,8 @@ INSTANCE: loc value
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached set-value-class vreg>> set-value-class ;
M: cached value-class* vreg>> value-class* ;
M: cached >vreg vreg>> >vreg ;
INSTANCE: cached value
@ -55,6 +63,8 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) f tagged boa ;
M: tagged set-value-class (>>class) ;
M: tagged value-class* class>> ;
M: tagged >vreg vreg>> ;
INSTANCE: tagged value
@ -71,20 +81,30 @@ INSTANCE: unboxed value
TUPLE: unboxed-alien < unboxed ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien value-class* drop simple-alien ;
! Untagged byte array pointer
TUPLE: unboxed-byte-array < unboxed ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array value-class* drop c-ptr ;
! A register set to f
TUPLE: unboxed-f < unboxed ;
C: <unboxed-f> unboxed-f
M: unboxed-f value-class* drop \ f ;
! An alien, byte array or f
TUPLE: unboxed-c-ptr < unboxed ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr value-class* drop c-ptr ;
! A constant value
TUPLE: constant value ;
C: <constant> constant
M: constant value-class* value>> class ;
INSTANCE: constant value

1
unfinished/compiler/cfg/rpo/rpo.factor
View File

@ -7,7 +7,6 @@ IN: compiler.cfg.rpo
: post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [
t >>visited
<label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;

91
unfinished/compiler/cfg/stacks/stacks.factor
View File

@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
@ -32,23 +30,19 @@ DEFER: %move
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
M: vreg value-class* reg-class>> value-class* ;
M: int-regs move-spec drop f ;
M: int-regs operand-class* drop object ;
M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
M: float-regs value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
@ -57,15 +51,13 @@ M: ds-loc live-loc?
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc value-class* class>> ;
M: loc set-value-class (>>class) ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
M: f operand-class* ;
M: f value-class* ;
M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
@ -75,41 +67,34 @@ M: cached lazy-store
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: constant operand-class* value>> class ;
M: constant move-spec class ;
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
dup value-class {
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
[ drop ##unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
int-regs next-vreg [ over %move operand-class ] keep
int-regs next-vreg [ over %move value-class ] keep
tagged new
swap >>vreg
swap >>class
@ -117,28 +102,28 @@ M: constant move-spec class ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ %copy ] }
{ { unboxed-alien unboxed-alien } [ %copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ %copy ] }
{ { unboxed-f unboxed-f } [ %copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
{ { float float } [ %copy-float ] }
{ { f f } [ ##copy ] }
{ { unboxed-alien unboxed-alien } [ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
{ { unboxed-f unboxed-f } [ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
{ { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> %load-literal ] }
{ { f constant } [ value>> ##load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { f float } [ ##box-float ] }
{ { f unboxed-alien } [ ##box-alien ] }
{ { f loc } [ ##peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { float f } [ ##unbox-float ] }
{ { unboxed-alien f } [ ##unbox-alien ] }
{ { unboxed-byte-array f } [ ##unbox-byte-array ] }
{ { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
{ { loc f } [ swap ##replace ] }
[ drop %move-via-temp ]
} case ;
@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
\ ##inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ;
\ ##inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
@ -265,7 +250,7 @@ SYMBOL: fresh-objects
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class
alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
@ -301,7 +286,7 @@ M: loc lazy-store
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
value-class over set-value-class
] if
] 2map
over stack>> delete-all
@ -330,10 +315,10 @@ M: loc lazy-store
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
: set-operand-classes ( classes -- )
: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ;
stack>> [ set-value-class ] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@ -342,7 +327,7 @@ M: loc lazy-store
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
: fresh-object ( obj -- ) fresh-objects get push ;
@ -358,14 +343,6 @@ M: loc lazy-store
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;

31
unfinished/compiler/cfg/templates/templates.factor
View File

@ -5,16 +5,7 @@ quotations combinators classes.algebra compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
USE: qualified
FROM: compiler.generator.registers => +input+ ;
FROM: compiler.generator.registers => +output+ ;
FROM: compiler.generator.registers => +scratch+ ;
FROM: compiler.generator.registers => +clobber+ ;
: template-input +input+ swap at ; inline
: template-output +output+ swap at ; inline
: template-scratch +scratch+ swap at ; inline
: template-clobber +clobber+ swap at ; inline
TUPLE: template input output scratch clobber gc ;
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
[ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq )
[ template-output ] [ template-clobber ] bi append ;
[ output>> ] [ clobber>> ] bi append ;
: clobbered? ( value name -- ? )
\ clobbered get member? [
@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
[
live-vregs \ live-vregs set
dup clobbered \ clobbered set
template-input [ values ] [ lazy-load ] bi zip
input>> [ values ] [ lazy-load ] bi zip
] with-scope ;
: alloc-scratch ( template -- assoc )
template-scratch [ swap alloc-vreg ] assoc-map ;
scratch>> [ swap alloc-vreg ] assoc-map ;
: do-template-inputs ( template -- inputs )
: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
#! registers.
[ load-inputs ] [ alloc-scratch ] bi assoc-union ;
[ alloc-scratch ] [ load-inputs ] bi ;
: do-template-outputs ( template inputs -- )
[ template-output ] dip '[ _ at ] map
: do-template-outputs ( template defs uses -- )
[ output>> ] 2dip assoc-union '[ _ at ] map
phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs )
[
first2 dup do-template-inputs
[ do-template-outputs ] keep
[ do-template-outputs ] 2keep
] dip call ; inline
: value-matches? ( value spec -- ? )
@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
>r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
template-input phantom-datastack get swap
input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f )

222
unfinished/compiler/backend/alien/alien.factor → unfinished/compiler/codegen/codegen.factor
View File

@ -1,16 +1,128 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.backend.alien
USING: namespaces make math math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
threads continuations.private libc combinators
alien alien.c-types alien.structs alien.strings
compiler.errors
compiler.alien
compiler.backend
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
: generate-insns ( insns -- code )
[
[
dup regs>> registers set
generate-insn
] each
] { } make fixup ;
TUPLE: asm label code calls ;
SYMBOL: calls
: add-call ( word -- )
#! Compile this word later.
calls get push ;
SYMBOL: compiling-word
: compiled-stack-traces? ( -- ? ) 59 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
: init-generator ( word -- )
H{ } clone labels set
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? compiling-word get f ? add-literal drop ;
: generate ( mr -- asm )
[
[ label>> ]
[ word>> init-generator ]
[ instructions>> generate-insns ] tri
calls get
asm boa
] with-scope ;
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
M: _label generate-insn
id>> lookup-label , ;
M: _prologue generate-insn
n>> %prologue ;
M: _epilogue generate-insn
n>> %epilogue ;
M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
M: ##return generate-insn drop %return ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
M: ##intrinsic generate-insn
[ init-intrinsic ] [ quot>> call ] bi ;
M: _if-intrinsic generate-insn
[ init-intrinsic ]
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> ] [ label>> lookup-label ] bi %jump-t ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn drop %dispatch ;
M: ##copy generate-insn %copy ;
M: ##copy-float generate-insn %copy-float ;
M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
M: ##gc generate-insn drop %gc ;
! #alien-invoke
: set-stack-frame ( n -- )
dup [ frame-required ] when* \ stack-frame set ;
: with-stack-frame ( n quot -- )
swap set-stack-frame
call
f set-stack-frame ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@ -55,17 +167,17 @@ M: object reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" c-type <repetition> % ;
: (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- )
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type , ;
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- )
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type
flatten-value-type %
] reduce drop
] { } make ;
@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
M: #alien-invoke generate-node
M: ##alien-invoke generate-insn
params>>
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
dup objects>registers
%prepare-var-args
dup alien-invoke-dlsym %alien-invoke
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! Save registers for GC
%prepare-alien-invoke
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call function
dup alien-invoke-dlsym %alien-invoke
! Box return value
dup %cleanup
box-return* ;
! #alien-indirect
M: #alien-indirect generate-node
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
dup alien-invoke-frame [
! Flush registers
end-basic-block
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
! Box return value
dup %cleanup
box-return* ;
! #alien-callback
! ##alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
@ -264,18 +373,9 @@ TUPLE: callback-context ;
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
: generate-callback ( params -- )
dup xt>> dup [
init-templates
%prologue
dup alien-stack-frame [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-cfg-builder ;
M: #alien-callback generate-node
end-basic-block
params>> generate-callback iterate-next ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri ;

77
unfinished/compiler/codegen/fixup/fixup.factor
View File

@ -3,76 +3,20 @@
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.cfg.fixup
combinators math.bitwise words.private math.order accessors
growable compiler.constants compiler.backend ;
IN: compiler.codegen.fixup
: no-stack-frame -1 ; inline
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
GENERIC: fixup* ( frame-size obj -- frame-size )
GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
TUPLE: label offset ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset >>offset drop ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
[ 2drop ] [ stack-frame swap call ] if ; inline
M: word fixup*
{
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
SYMBOL: label-table
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute? ( n -- ? )
dup rc-absolute-cell =
over rc-absolute =
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
M: label fixup* compiled-offset >>offset drop ;
TUPLE: label-fixup label class ;
@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label>> swap class>> compiled-offset 4 - rot
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
@ -97,8 +41,6 @@ M: rel-fixup fixup*
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
: adjoin* ( obj table -- n )
@ -143,12 +85,11 @@ SYMBOL: literal-table
3array
] map concat ;
: fixup ( code -- literals relocation labels code )
: fixup ( fixup-directives -- code )
[
init-fixup
dup stack-frame-size swap [ fixup* ] each drop
[ fixup* ] each
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;
] { } make 4array ;

116
unfinished/compiler/new/new.factor Normal file
View File

@ -0,0 +1,116 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.linearization compiler.cfg.linear-scan
compiler.codegen ;
IN: compiler.new
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
: ripple-up ( words -- )
dup "compiled-effect" word-prop +failed+ eq?
[ usage [ word? ] filter ] [ compiled-usage keys ] if
[ queue-compile ] each ;
: ripple-up? ( word effect -- ? )
#! If the word has previously been compiled and had a
#! different stack effect, we have to recompile any callers.
swap "compiled-effect" word-prop [ = not ] keep and ;
: save-effect ( word effect -- )
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
[ "compiled-effect" set-word-prop ]
2bi ;
: start ( word -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
: fail ( word error -- )
[ swap compiler-error ]
[
drop
[ compiled-unxref ]
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
] 2bi
return ;
: frontend ( word -- effect nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
compiled-xref
] [ drop ] if
] tri ;
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ calls>> [ queue-compile ] each ]
bi ;
: backend ( nodes word -- )
build-cfg [ build-mr linear-scan generate save-asm ] each ;
: (compile) ( word -- )
'[
_ {
[ start ]
[ frontend ]
[ backend ]
[ finish ]
} cleave
] with-return ;
: compile-loop ( deque -- )
[ (compile) yield ] slurp-deque ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;