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

Updating x86 backend for new codegen

db4
Slava Pestov 2008-09-17 00:46:38 -05:00
parent ae8af068db
commit 6cad2e02e4
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 - ; : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ; : 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. ! 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 IN: compiler.backend
! Is this structure small enough to be returned in registers? ! Labels
HOOK: struct-small-enough? cpu ( size -- ? ) 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 ! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc ) 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. ! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers USING: alien.c-types arrays kernel kernel.private math
compiler.backend ; 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 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 M: x86.32 machine-registers
{ {
{ int-regs { EAX ECX EDX EBP EBX } } { int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } } { 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. ! See http://factorcode.org/license.txt for BSD license.
USING: system cpu.x86.assembler compiler.cfg.registers USING: accessors alien.c-types arrays kernel kernel.private math
compiler.backend ; 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 IN: compiler.backend.x86.64
M: x86.64 machine-registers M: x86.64 machine-registers
@ -12,3 +16,211 @@ M: x86.64 machine-registers
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 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 ; : 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: procedures
SYMBOL: current-word SYMBOL: current-word
SYMBOL: current-label SYMBOL: current-label
SYMBOL: loops SYMBOL: loops
! Basic block after prologue, makes recursion faster ! 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 #! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue. #! calls can skip an epilogue/prologue.
init-phantoms init-phantoms
%prologue ##prologue
%branch ##branch
begin-basic-block begin-basic-block
current-label get remember-loop ; current-label get remember-loop ;
@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
[ emit-nodes ] with-node-iterator [ emit-nodes ] with-node-iterator
] with-cfg-builder ; ] with-cfg-builder ;
: build-cfg ( nodes word label -- procedures ) : build-cfg ( nodes word -- procedures )
V{ } clone [ V{ } clone [
procedures [ procedures [
(build-cfg) dup (build-cfg)
] with-variable ] with-variable
] keep ; ] keep ;
SYMBOL: +intrinsics+
SYMBOL: +if-intrinsics+
: if-intrinsics ( #call -- quot ) : if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ; word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next ) : local-recursive-call ( basic-block -- next )
%branch ##branch
basic-block get successors>> push basic-block get successors>> push
stop-iterating ; stop-iterating ;
: emit-call ( word -- next ) : emit-call ( word -- next )
finalize-phantoms 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 ] } { [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ %epilogue %jump stop-iterating ] [ ##epilogue ##jump stop-iterating ]
} cond ; } cond ;
! #recursive ! #recursive
@ -130,50 +124,52 @@ M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ; dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if ! #if
: emit-branch ( nodes -- final-bb ) : emit-branch ( obj quot -- final-bb )
[ '[
begin-basic-block copy-phantoms begin-basic-block copy-phantoms
emit-nodes @
basic-block get dup [ %branch ] when basic-block get dup [ ##branch ] when
] with-scope ; ] with-scope ;
: emit-if ( node -- next ) : emit-branches ( seq quot -- )
children>> [ emit-branch ] map '[ _ emit-branch ] map
end-basic-block end-basic-block
begin-basic-block begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each basic-block get '[ [ _ swap successors>> push ] when* ] each
init-phantoms init-phantoms ;
iterate-next ;
: emit-if ( node -- next )
children>> [ emit-nodes ] emit-branches ;
M: #if emit-node M: #if emit-node
{ { f "flag" } } lazy-load first %branch-t { { f "flag" } } lazy-load first ##branch-t
emit-if ; emit-if iterate-next ;
! #dispatch ! #dispatch
: dispatch-branch ( nodes word -- label ) : 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 [ gensym [
[ [
copy-phantoms copy-phantoms
%prologue ##prologue
[ emit-nodes ] with-node-iterator [ emit-nodes ] with-node-iterator
%epilogue ##epilogue
%return ##return
] with-cfg-builder ] with-cfg-builder
] keep ; ] keep ;
: dispatch-branches ( node -- ) : dispatch-branches ( node -- )
children>> [ children>> [
current-word get dispatch-branch current-word get dispatch-branch
%dispatch-label ##dispatch-label
] each ; ] each ;
: emit-dispatch ( node -- ) : emit-dispatch ( node -- )
%dispatch dispatch-branches init-phantoms ; ##epilogue ##dispatch dispatch-branches init-phantoms ;
M: #dispatch emit-node 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? [ tail-call? [
emit-dispatch iterate-next emit-dispatch iterate-next
] [ ] [
@ -187,23 +183,23 @@ M: #dispatch emit-node
! #call ! #call
: define-intrinsics ( word intrinsics -- ) : define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ; +intrinsics+ set-word-prop ;
: define-intrinsic ( word quot assoc -- ) : define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ; 2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- ) : define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map [ template new swap >>input ] assoc-map
"if-intrinsics" set-word-prop ; +if-intrinsics+ set-word-prop ;
: define-if-intrinsic ( word quot inputs -- ) : define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ; 2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f ) : find-intrinsic ( #call -- pair/f )
word>> "intrinsics" word-prop find-template ; word>> +intrinsics+ word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f ) : 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 ) : find-if-intrinsic ( #call -- pair/f )
node@ { node@ {
@ -213,21 +209,24 @@ M: #dispatch emit-node
} cond ; } cond ;
: do-if-intrinsic ( pair -- next ) : 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 ) : do-boolean-intrinsic ( pair -- next )
[ [ ##if-intrinsic ] apply-template
f alloc-vreg [ %boolean-intrinsic ] keep phantom-push { t f } [
] apply-template iterate-next ; <constant> phantom-push finalize-phantoms
] emit-branches
iterate-next ;
: do-intrinsic ( pair -- next ) : do-intrinsic ( pair -- next )
[ %intrinsic ] apply-template iterate-next ; [ ##intrinsic ] apply-template iterate-next ;
: setup-operand-classes ( #call -- ) : setup-value-classes ( #call -- )
node-input-infos [ class>> ] map set-operand-classes ; node-input-infos [ class>> ] map set-value-classes ;
M: #call emit-node M: #call emit-node
dup setup-operand-classes dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [ dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [ dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [ dup find-intrinsic [ do-intrinsic ] [
@ -259,12 +258,12 @@ M: #r> emit-node
! #return ! #return
M: #return emit-node M: #return emit-node
drop finalize-phantoms %epilogue %return f ; drop finalize-phantoms ##epilogue ##return f ;
M: #return-recursive emit-node M: #return-recursive emit-node
finalize-phantoms finalize-phantoms
label>> id>> loops get key? label>> id>> loops get key?
[ %epilogue %return ] unless f ; [ ##epilogue ##return ] unless f ;
! #terminate ! #terminate
M: #terminate emit-node drop stop-iterating ; M: #terminate emit-node drop stop-iterating ;
@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
! FFI ! FFI
M: #alien-invoke emit-node M: #alien-invoke emit-node
params>> params>>
[ alien-invoke-frame %frame-required ] [ alien-invoke-frame ##frame-required ]
[ %alien-invoke iterate-next ] [ ##alien-invoke iterate-next ]
bi ; bi ;
M: #alien-indirect emit-node M: #alien-indirect emit-node
params>> params>>
[ alien-invoke-frame %frame-required ] [ alien-invoke-frame ##frame-required ]
[ %alien-indirect iterate-next ] [ ##alien-indirect iterate-next ]
bi ; bi ;
M: #alien-callback emit-node M: #alien-callback emit-node
params>> dup xt>> dup params>> dup xt>> dup
[ init-phantoms %alien-callback ] with-cfg-builder [ init-phantoms ##alien-callback ] with-cfg-builder
iterate-next ; iterate-next ;
! No-op nodes ! No-op nodes

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

@ -11,16 +11,13 @@ C: <cfg> cfg
TUPLE: basic-block < identity-tuple TUPLE: basic-block < identity-tuple
visited visited
number number
label
instructions instructions
successors successors ;
predecessors ;
: <basic-block> ( -- basic-block ) : <basic-block> ( -- basic-block )
basic-block new basic-block new
V{ } clone >>instructions V{ } clone >>instructions
V{ } clone >>successors V{ } clone >>successors ;
V{ } clone >>predecessors ;
TUPLE: mr instructions word label ; 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 ) GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg M: callable test-cfg
build-tree optimize-tree gensym gensym build-cfg ; build-tree optimize-tree gensym build-cfg ;
M: word test-cfg M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep dup [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ; : 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 ! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: %cond-branch < insn src ; TUPLE: ##cond-branch < insn src ;
TUPLE: %unary < insn dst src ; TUPLE: ##unary < insn dst src ;
TUPLE: %nullary < insn dst ; TUPLE: ##nullary < insn dst ;
! Stack operations ! Stack operations
INSN: %load-literal < %nullary obj ; INSN: ##load-literal < ##nullary obj ;
INSN: %peek < %nullary loc ; INSN: ##peek < ##nullary loc ;
INSN: %replace src loc ; INSN: ##replace src loc ;
INSN: %inc-d n ; INSN: ##inc-d n ;
INSN: %inc-r n ; INSN: ##inc-r n ;
! Calling convention ! Calling convention
INSN: %return ; INSN: ##return ;
! Subroutine calls ! Subroutine calls
INSN: %call word ; INSN: ##call word ;
INSN: %jump word ; INSN: ##jump word ;
INSN: %intrinsic quot regs ; INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables ! Jump tables
INSN: %dispatch-label label ; INSN: ##dispatch-label label ;
INSN: %dispatch ; INSN: ##dispatch ;
! Boxing and unboxing ! Boxing and unboxing
INSN: %copy < %unary ; INSN: ##copy < ##unary ;
INSN: %copy-float < %unary ; INSN: ##copy-float < ##unary ;
INSN: %unbox-float < %unary ; INSN: ##unbox-float < ##unary ;
INSN: %unbox-f < %unary ; INSN: ##unbox-f < ##unary ;
INSN: %unbox-alien < %unary ; INSN: ##unbox-alien < ##unary ;
INSN: %unbox-byte-array < %unary ; INSN: ##unbox-byte-array < ##unary ;
INSN: %unbox-any-c-ptr < %unary ; INSN: ##unbox-any-c-ptr < ##unary ;
INSN: %box-float < %unary ; INSN: ##box-float < ##unary ;
INSN: %box-alien < %unary ; INSN: ##box-alien < ##unary ;
INSN: %gc ; INSN: ##gc ;
! FFI ! FFI
INSN: %alien-invoke params ; INSN: ##alien-invoke params ;
INSN: %alien-indirect params ; INSN: ##alien-indirect params ;
INSN: %alien-callback params ; INSN: ##alien-callback params ;
GENERIC: defs-vregs ( insn -- seq ) GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq )
M: %nullary defs-vregs dst>> >vreg 1array ; M: ##nullary defs-vregs dst>> >vreg 1array ;
M: %unary defs-vregs dst>> >vreg 1array ; M: ##unary defs-vregs dst>> >vreg 1array ;
M: insn defs-vregs drop f ; M: insn defs-vregs drop f ;
M: %replace uses-vregs src>> >vreg 1array ; M: ##replace uses-vregs src>> >vreg 1array ;
M: %unary uses-vregs src>> >vreg 1array ; M: ##unary uses-vregs src>> >vreg 1array ;
M: insn uses-vregs drop f ; 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. ! Instructions used by CFG IR only.
INSN: %prologue ; INSN: ##prologue ;
INSN: %epilogue ; INSN: ##epilogue ;
INSN: %frame-required n ; INSN: ##frame-required n ;
INSN: %branch ; INSN: ##branch ;
INSN: %branch-f < %cond-branch ; INSN: ##branch-f < ##cond-branch ;
INSN: %branch-t < %cond-branch ; INSN: ##branch-t < ##cond-branch ;
INSN: %if-intrinsic quot vregs ; INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
INSN: %boolean-intrinsic quot vregs dst ;
M: %cond-branch uses-vregs src>> 1array ; 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 ;
M: %boolean-intrinsic defs-vregs dst>> 1array ;
! M: %boolean-intrinsic uses-vregs
! [ vregs>> values ] [ out>> ] bi suffix ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
INSN: _prologue n ; INSN: _prologue n ;
INSN: _epilogue n ; INSN: _epilogue n ;
TUPLE: label id ; INSN: _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 ;
TUPLE: _cond-branch < insn src label ; TUPLE: _cond-branch < insn src label ;
INSN: _branch label ; INSN: _branch label ;
INSN: _branch-f < _cond-branch ; INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _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: _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: _spill src n ;
INSN: _reload dst 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 kernel fry arrays splitting namespaces math accessors vectors
math.order math.order
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.debugger ; compiler.cfg.linear-scan.debugger ;
@ -98,3 +99,7 @@ SYMBOL: max-uses
[ ] [ 10 4 2 60 random-test ] unit-test [ ] [ 10 4 2 60 random-test ] unit-test
[ ] [ 10 20 2 400 random-test ] unit-test [ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 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 ; compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan 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/ ! 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' ) : linear-scan ( mr -- mr' )
[ [
dup compute-live-intervals 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 ; at [ (>>end) ] [ uses>> push ] 2bi ;
: new-live-interval ( n vreg live-intervals -- ) : new-live-interval ( n vreg live-intervals -- )
2dup key? [ "Multiple defs" throw ] when
[ [ <live-interval> ] keep ] dip set-at ; [ [ <live-interval> ] keep ] dip set-at ;
: compute-live-intervals* ( insn n -- ) : 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 SYMBOL: frame-size
: compute-frame-size ( rpo -- ) : compute-frame-size ( rpo -- )
[ instructions>> [ %frame-required? ] filter ] map concat [ instructions>> [ ##frame-required? ] filter ] map concat
[ f ] [ [ n>> ] map supremum ] if-empty [ f ] [ [ n>> ] map supremum ] if-empty
frame-size set ; frame-size set ;
@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
M: insn linearize-insn , drop ; 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* ; 2drop frame-size get [ _prologue ] when* ;
M: %epilogue linearize-insn M: ##epilogue linearize-insn
2drop frame-size get [ _epilogue ] when* ; 2drop frame-size get [ _epilogue ] when* ;
: useless-branch? ( basic-block successor -- ? ) : useless-branch? ( basic-block successor -- ? )
@ -39,50 +39,40 @@ M: %epilogue linearize-insn
: branch-to-return? ( successor -- ? ) : branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned. #! A branch to a block containing just a return is cloned.
instructions>> dup length 2 = [ instructions>> dup length 2 = [
[ first %epilogue? ] [ second %return? ] bi and [ first ##epilogue? ] [ second ##return? ] bi and
] [ drop f ] if ; ] [ drop f ] if ;
: emit-branch ( basic-block successor -- ) : emit-branch ( basic-block successor -- )
{ {
{ [ 2dup useless-branch? ] [ 2drop ] } { [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-return? ] [ nip linearize-insns ] } { [ dup branch-to-return? ] [ nip linearize-insns ] }
[ nip label>> _branch ] [ nip number>> _branch ]
} cond ; } cond ;
M: %branch linearize-insn M: ##branch linearize-insn
drop dup successors>> first emit-branch ; drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 ) : 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 ) : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
[ conditional ] [ src>> ] bi* swap ; inline [ conditional ] [ src>> ] bi* swap ; inline
M: %branch-f linearize-insn M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ; boolean-conditional _branch-f emit-branch ;
M: %branch-t linearize-insn M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ; boolean-conditional _branch-t emit-branch ;
M: %if-intrinsic linearize-insn : >intrinsic< ( insn -- quot defs uses )
[ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi* [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
M: ##if-intrinsic linearize-insn
[ conditional ] [ >intrinsic< ] bi*
_if-intrinsic emit-branch ; _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 -- ) : linearize-basic-block ( bb -- )
[ label>> _label ] [ linearize-insns ] bi ; [ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns ) : linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ; [ [ linearize-basic-block ] each ] { } make ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: compiler.cfg.registers
! Virtual CPU registers, used by CFG and machine IRs ! Virtual CPU registers, used by CFG and machine IRs
@ -8,8 +8,14 @@ IN: compiler.cfg.registers
MIXIN: value MIXIN: value
GENERIC: >vreg ( obj -- vreg ) 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 >vreg drop f ;
M: value set-value-class 2drop ;
M: value value-class* drop f ;
! Register classes ! Register classes
SINGLETON: int-regs SINGLETON: int-regs
@ -47,6 +53,8 @@ INSTANCE: loc value
TUPLE: cached loc vreg ; TUPLE: cached loc vreg ;
C: <cached> cached C: <cached> cached
M: cached set-value-class vreg>> set-value-class ;
M: cached value-class* vreg>> value-class* ;
M: cached >vreg vreg>> >vreg ; M: cached >vreg vreg>> >vreg ;
INSTANCE: cached value INSTANCE: cached value
@ -55,6 +63,8 @@ INSTANCE: cached value
TUPLE: tagged vreg class ; TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) f tagged boa ; : <tagged> ( vreg -- tagged ) f tagged boa ;
M: tagged set-value-class (>>class) ;
M: tagged value-class* class>> ;
M: tagged >vreg vreg>> ; M: tagged >vreg vreg>> ;
INSTANCE: tagged value INSTANCE: tagged value
@ -71,20 +81,30 @@ INSTANCE: unboxed value
TUPLE: unboxed-alien < unboxed ; TUPLE: unboxed-alien < unboxed ;
C: <unboxed-alien> unboxed-alien C: <unboxed-alien> unboxed-alien
M: unboxed-alien value-class* drop simple-alien ;
! Untagged byte array pointer ! Untagged byte array pointer
TUPLE: unboxed-byte-array < unboxed ; TUPLE: unboxed-byte-array < unboxed ;
C: <unboxed-byte-array> unboxed-byte-array C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array value-class* drop c-ptr ;
! A register set to f ! A register set to f
TUPLE: unboxed-f < unboxed ; TUPLE: unboxed-f < unboxed ;
C: <unboxed-f> unboxed-f C: <unboxed-f> unboxed-f
M: unboxed-f value-class* drop \ f ;
! An alien, byte array or f ! An alien, byte array or f
TUPLE: unboxed-c-ptr < unboxed ; TUPLE: unboxed-c-ptr < unboxed ;
C: <unboxed-c-ptr> unboxed-c-ptr C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr value-class* drop c-ptr ;
! A constant value ! A constant value
TUPLE: constant value ; TUPLE: constant value ;
C: <constant> constant C: <constant> constant
M: constant value-class* value>> class ;
INSTANCE: constant value 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 -- ) : post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [ dup visited>> [ drop ] [
t >>visited t >>visited
<label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi [ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ; ] if ;

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

@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag SYMBOL: known-tag
! Value protocol ! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec ) GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? ) GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value ) GENERIC# (lazy-load) 1 ( value spec -- value )
@ -32,23 +30,19 @@ DEFER: %move
PRIVATE> PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation ! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-loc? 2drop f ; M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ; M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ; M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ; 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 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 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 minimal-ds-loc* n>> min ;
M: ds-loc live-loc? M: ds-loc live-loc?
@ -57,15 +51,13 @@ M: ds-loc live-loc?
M: rs-loc live-loc? M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
M: loc operand-class* class>> ; M: loc value-class* class>> ;
M: loc set-operand-class (>>class) ; M: loc set-value-class (>>class) ;
M: loc move-spec drop loc ; M: loc move-spec drop loc ;
M: f 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 move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ; M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ; M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
@ -75,41 +67,34 @@ M: cached lazy-store
[ "live-locs" get at %move ] [ 2drop ] if ; [ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ; 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: tagged move-spec drop f ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ; M: unboxed-alien move-spec class ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ; M: unboxed-byte-array move-spec class ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ; M: unboxed-f move-spec class ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ; M: unboxed-c-ptr move-spec class ;
M: constant operand-class* value>> class ;
M: constant move-spec class ; M: constant move-spec class ;
! Moving values between locations and registers ! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ; : %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- ) : %unbox-c-ptr ( dst src -- )
dup operand-class { dup value-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] } { [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] } { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] } { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
[ drop %unbox-any-c-ptr ] [ drop ##unbox-any-c-ptr ]
} cond ; inline } cond ; inline
: %move-via-temp ( dst src -- ) : %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we #! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to #! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination. #! 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 tagged new
swap >>vreg swap >>vreg
swap >>class swap >>class
@ -117,28 +102,28 @@ M: constant move-spec class ;
: %move ( dst src -- ) : %move ( dst src -- )
2dup [ move-spec ] bi@ 2array { 2dup [ move-spec ] bi@ 2array {
{ { f f } [ %copy ] } { { f f } [ ##copy ] }
{ { unboxed-alien unboxed-alien } [ %copy ] } { { unboxed-alien unboxed-alien } [ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ %copy ] } { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
{ { unboxed-f unboxed-f } [ %copy ] } { { unboxed-f unboxed-f } [ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ %copy ] } { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
{ { float float } [ %copy-float ] } { { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] } { { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] } { { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> %load-literal ] } { { f constant } [ value>> ##load-literal ] }
{ { f float } [ %box-float ] } { { f float } [ ##box-float ] }
{ { f unboxed-alien } [ %box-alien ] } { { f unboxed-alien } [ ##box-alien ] }
{ { f loc } [ %peek ] } { { f loc } [ ##peek ] }
{ { float f } [ %unbox-float ] } { { float f } [ ##unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] } { { unboxed-alien f } [ ##unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] } { { unboxed-byte-array f } [ ##unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] } { { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] } { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] } { { loc f } [ swap ##replace ] }
[ drop %move-via-temp ] [ drop %move-via-temp ]
} case ; } case ;
@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ; M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ; \ ##inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ; TUPLE: phantom-retainstack < phantom-stack ;
@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ; M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ; \ ##inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs ) : phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack. #! A sequence of n ds-locs or rs-locs indexing the stack.
@ -265,7 +250,7 @@ SYMBOL: fresh-objects
} cond 2nip ; } cond 2nip ;
: alloc-vreg-for ( value spec -- vreg ) : alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ; over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load) M: value (lazy-load)
@ -301,7 +286,7 @@ M: loc lazy-store
dup phantom-locs* dup phantom-locs*
over stack>> [ over stack>> [
dup constant? [ nip ] [ dup constant? [ nip ] [
operand-class over set-operand-class value-class over set-value-class
] if ] if
] 2map ] 2map
over stack>> delete-all over stack>> delete-all
@ -330,10 +315,10 @@ M: loc lazy-store
: clear-phantoms ( -- ) : clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ; [ stack>> delete-all ] each-phantom ;
: set-operand-classes ( classes -- ) : set-value-classes ( classes -- )
phantom-datastack get phantom-datastack get
over length over add-locs over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ; stack>> [ set-value-class ] 2reverse-each ;
: finalize-phantoms ( -- ) : finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the #! Commit all deferred stacking shuffling, and ensure the
@ -342,7 +327,7 @@ M: loc lazy-store
finalize-contents finalize-contents
clear-phantoms clear-phantoms
finalize-heights 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 ; : fresh-object ( obj -- ) fresh-objects get push ;
@ -358,14 +343,6 @@ M: loc lazy-store
phantom-datastack [ clone ] change phantom-datastack [ clone ] change
phantom-retainstack [ 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 -- ) : phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom 1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ; 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 ; compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates IN: compiler.cfg.templates
USE: qualified TUPLE: template input output scratch clobber gc ;
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
: phantom&spec ( phantom specs -- phantom' specs' ) : phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r> >r stack>> r>
@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
[ stack>> [ >vreg ] map sift ] each-phantom append ; [ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq ) : clobbered ( template -- seq )
[ template-output ] [ template-clobber ] bi append ; [ output>> ] [ clobber>> ] bi append ;
: clobbered? ( value name -- ? ) : clobbered? ( value name -- ? )
\ clobbered get member? [ \ clobbered get member? [
@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
[ [
live-vregs \ live-vregs set live-vregs \ live-vregs set
dup clobbered \ clobbered set dup clobbered \ clobbered set
template-input [ values ] [ lazy-load ] bi zip input>> [ values ] [ lazy-load ] bi zip
] with-scope ; ] with-scope ;
: alloc-scratch ( template -- assoc ) : 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 #! Load input values into registers and allocates scratch
#! registers. #! registers.
[ load-inputs ] [ alloc-scratch ] bi assoc-union ; [ alloc-scratch ] [ load-inputs ] bi ;
: do-template-outputs ( template inputs -- ) : do-template-outputs ( template defs uses -- )
[ template-output ] dip '[ _ at ] map [ output>> ] 2dip assoc-union '[ _ at ] map
phantom-datastack get phantom-append ; phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs ) : apply-template ( pair quot -- vregs )
[ [
first2 dup do-template-inputs first2 dup do-template-inputs
[ do-template-outputs ] keep [ do-template-outputs ] 2keep
] dip call ; inline ] dip call ; inline
: value-matches? ( value spec -- ? ) : value-matches? ( value spec -- ? )
@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
: spec-matches? ( value spec -- ? ) : spec-matches? ( value spec -- ? )
2dup first value-matches? 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-matches? ( template -- ? )
template-input phantom-datastack get swap input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ; [ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f ) : 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. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ! #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 ) GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ; M: int-regs reg-size drop cell ;
@ -55,17 +167,17 @@ M: object reg-class-full?
[ spill-param ] [ fastcall-param ] if [ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ; [ param-reg ] keep ;
: (flatten-int-type) ( size -- ) : (flatten-int-type) ( size -- seq )
cell /i "void*" c-type <repetition> % ; 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) ; 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) ; stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params ) : flatten-value-types ( params -- params )
@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
[ [
0 [ 0 [
c-type c-type
[ parameter-align (flatten-int-type) ] keep [ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep [ stack-size cell align + ] keep
flatten-value-type flatten-value-type %
] reduce drop ] reduce drop
] { } make ; ] { } make ;
@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
swap library>> library dup [ dll>> ] when swap library>> library dup [ dll>> ] when
2dup check-dlsym ; 2dup check-dlsym ;
M: #alien-invoke generate-node M: ##alien-invoke generate-insn
params>> params>>
dup alien-invoke-frame [ ! Save registers for GC
end-basic-block %prepare-alien-invoke
%prepare-alien-invoke ! Unbox parameters
dup objects>registers dup objects>registers
%prepare-var-args %prepare-var-args
dup alien-invoke-dlsym %alien-invoke ! Call function
dup %cleanup dup alien-invoke-dlsym %alien-invoke
box-return* ! Box return value
iterate-next dup %cleanup
] with-stack-frame ; box-return* ;
! #alien-indirect ! ##alien-indirect
M: #alien-indirect generate-node M: ##alien-indirect generate-insn
params>> params>>
dup alien-invoke-frame [ ! Save registers for GC
! Flush registers %prepare-alien-invoke
end-basic-block ! Save alien at top of stack to temporary storage
! Save registers for GC %prepare-alien-indirect
%prepare-alien-invoke ! Unbox parameters
! Save alien at top of stack to temporary storage dup objects>registers
%prepare-alien-indirect %prepare-var-args
dup objects>registers ! Call alien in temporary storage
%prepare-var-args %alien-indirect
! Call alien in temporary storage ! Box return value
%alien-indirect dup %cleanup
dup %cleanup box-return* ;
box-return*
iterate-next
] with-stack-frame ;
! #alien-callback ! ##alien-callback
: box-parameters ( params -- ) : box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ; alien-parameters [ box-parameter ] each-parameter ;
@ -264,18 +373,9 @@ TUPLE: callback-context ;
[ %unnest-stacks ] [ %callback-value ] if-void [ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ; callback-unwind %unwind ;
: generate-callback ( params -- ) M: ##alien-callback generate-insn
dup xt>> dup [ params>>
init-templates [ registers>objects ]
%prologue [ wrap-callback-quot %alien-callback ]
dup alien-stack-frame [ [ %callback-return ]
[ registers>objects ] tri ;
[ 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 ;

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

@ -3,76 +3,20 @@
USING: arrays byte-arrays generic assocs hashtables io.binary USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture combinators math.bitwise words.private math.order accessors
math.order accessors growable ; growable compiler.constants compiler.backend ;
IN: compiler.cfg.fixup IN: compiler.codegen.fixup
: no-stack-frame -1 ; inline GENERIC: fixup* ( obj -- )
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 )
: code-format 22 getenv ; : code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ; : 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: relocation-table
SYMBOL: label-table SYMBOL: label-table
! Relocation classes M: label fixup* compiled-offset >>offset drop ;
: 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 ;
TUPLE: label-fixup label class ; TUPLE: label-fixup label class ;
@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup* M: label-fixup fixup*
dup class>> rc-absolute? dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when [ "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 ; 3array label-table get push ;
TUPLE: rel-fixup arg class type ; TUPLE: rel-fixup arg class type ;
@ -97,8 +41,6 @@ M: rel-fixup fixup*
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ; [ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ; M: integer fixup* , ;
: adjoin* ( obj table -- n ) : adjoin* ( obj table -- n )
@ -143,12 +85,11 @@ SYMBOL: literal-table
3array 3array
] map concat ; ] map concat ;
: fixup ( code -- literals relocation labels code ) : fixup ( fixup-directives -- code )
[ [
init-fixup init-fixup
dup stack-frame-size swap [ fixup* ] each drop [ fixup* ] each
literal-table get >array literal-table get >array
relocation-table get >byte-array relocation-table get >byte-array
label-table get resolve-labels 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 ;