compiler: remove flat machine representation and generate code directly from the CFG
Slava Pestov
parent
5236f327ba
commit
f5c5d8b44c
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors math.order assocs kernel sequences
|
||||
combinators make classes words cpu.architecture layouts
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stack-frame ;
|
||||
combinators classes words cpu.architecture layouts compiler.cfg
|
||||
compiler.cfg.rpo compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stack-frame ;
|
||||
IN: compiler.cfg.build-stack-frame
|
||||
|
||||
SYMBOL: frame-required?
|
||||
|
|
@ -30,43 +30,24 @@ M: ##call-gc compute-stack-frame*
|
|||
frame-required? on
|
||||
stack-frame new t >>calls-vm? request-stack-frame ;
|
||||
|
||||
M: _spill-area-size compute-stack-frame*
|
||||
n>> stack-frame get (>>spill-area-size) ;
|
||||
|
||||
M: insn compute-stack-frame*
|
||||
class frame-required? word-prop [
|
||||
frame-required? on
|
||||
] when ;
|
||||
class "frame-required?" word-prop
|
||||
[ frame-required? on ] when ;
|
||||
|
||||
! PowerPC backend sets frame-required? for ##integer>float!
|
||||
\ ##spill t frame-required? set-word-prop
|
||||
\ ##unary-float-function t frame-required? set-word-prop
|
||||
\ ##binary-float-function t frame-required? set-word-prop
|
||||
: initial-stack-frame ( -- stack-frame )
|
||||
stack-frame new cfg get spill-area-size>> >>spill-area-size ;
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
stack-frame new stack-frame set
|
||||
[ compute-stack-frame* ] each
|
||||
initial-stack-frame stack-frame set
|
||||
[ instructions>> [ compute-stack-frame* ] each ] each-basic-block
|
||||
stack-frame get dup stack-frame-size >>total-size drop ;
|
||||
|
||||
GENERIC: insert-pro/epilogues* ( insn -- )
|
||||
|
||||
M: ##prologue insert-pro/epilogues*
|
||||
drop frame-required? get [ stack-frame get _prologue ] when ;
|
||||
|
||||
M: ##epilogue insert-pro/epilogues*
|
||||
drop frame-required? get [ stack-frame get _epilogue ] when ;
|
||||
|
||||
M: insn insert-pro/epilogues* , ;
|
||||
|
||||
: insert-pro/epilogues ( insns -- insns )
|
||||
[ [ insert-pro/epilogues* ] each ] { } make ;
|
||||
|
||||
: build-stack-frame ( mr -- mr )
|
||||
: build-stack-frame ( cfg -- cfg )
|
||||
[
|
||||
[ compute-stack-frame ]
|
||||
[
|
||||
[ compute-stack-frame ]
|
||||
[ insert-pro/epilogues ]
|
||||
bi
|
||||
] change-instructions
|
||||
frame-required? get stack-frame get f ?
|
||||
>>stack-frame
|
||||
] bi
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
USING: tools.test kernel sequences words sequences.private fry
|
||||
prettyprint alien alien.accessors math.private compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
|
||||
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
|
||||
compiler.cfg arrays locals byte-arrays kernel.private math
|
||||
slots.private vectors sbufs strings math.partial-dispatch
|
||||
hashtables assocs combinators.short-circuit
|
||||
strings.private accessors compiler.cfg.instructions
|
||||
compiler.cfg.representations ;
|
||||
prettyprint alien alien.accessors math.private
|
||||
compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.debugger
|
||||
compiler.cfg.optimizer compiler.cfg.rpo
|
||||
compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
|
||||
arrays locals byte-arrays kernel.private math slots.private
|
||||
vectors sbufs strings math.partial-dispatch hashtables assocs
|
||||
combinators.short-circuit strings.private accessors
|
||||
compiler.cfg.instructions compiler.cfg.representations ;
|
||||
FROM: alien.c-types => int ;
|
||||
IN: compiler.cfg.builder.tests
|
||||
|
||||
|
|
@ -161,8 +162,8 @@ IN: compiler.cfg.builder.tests
|
|||
] each
|
||||
|
||||
: count-insns ( quot insn-check -- ? )
|
||||
[ test-regs [ instructions>> ] map ] dip
|
||||
'[ _ count ] map-sum ; inline
|
||||
[ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
|
||||
count ; inline
|
||||
|
||||
: contains-insn? ( quot insn-check -- ? )
|
||||
count-insns 0 > ; inline
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ M: basic-block hashcode* nip id>> ;
|
|||
|
||||
TUPLE: cfg { entry basic-block } word label
|
||||
spill-area-size
|
||||
stack-frame
|
||||
post-order linear-order
|
||||
predecessors-valid? dominance-valid? loops-valid? ;
|
||||
|
||||
|
|
@ -42,11 +43,3 @@ predecessors-valid? dominance-valid? loops-valid? ;
|
|||
|
||||
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
|
||||
[ dup cfg ] dip with-variable ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
mr new
|
||||
swap >>label
|
||||
swap >>word
|
||||
swap >>instructions ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: kernel combinators.short-circuit accessors math sequences
|
||||
sets assocs compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.def-use compiler.cfg.linearization
|
||||
compiler.cfg.utilities compiler.cfg.finalization compiler.cfg.mr
|
||||
compiler.cfg.utilities compiler.cfg.finalization
|
||||
compiler.utilities ;
|
||||
IN: compiler.cfg.checker
|
||||
|
||||
|
|
@ -52,18 +52,5 @@ ERROR: bad-successors ;
|
|||
[ check-successors ]
|
||||
bi ;
|
||||
|
||||
ERROR: bad-live-in ;
|
||||
|
||||
ERROR: undefined-values uses defs ;
|
||||
|
||||
: check-mr ( mr -- )
|
||||
! Check that every used register has a definition
|
||||
instructions>>
|
||||
[ [ uses-vregs ] map concat ]
|
||||
[ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
|
||||
2dup subset? [ 2drop ] [ undefined-values ] if ;
|
||||
|
||||
: check-cfg ( cfg -- )
|
||||
[ [ check-basic-block ] each-basic-block ]
|
||||
[ finalize-cfg build-mr check-mr ]
|
||||
bi ;
|
||||
[ check-basic-block ] each-basic-block ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel words sequences quotations namespaces io vectors
|
||||
arrays hashtables classes.tuple accessors prettyprint
|
||||
|
|
@ -9,10 +9,11 @@ compiler.cfg.linearization compiler.cfg.registers
|
|||
compiler.cfg.stack-frame compiler.cfg.linear-scan
|
||||
compiler.cfg.optimizer compiler.cfg.finalization
|
||||
compiler.cfg.instructions compiler.cfg.utilities
|
||||
compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
|
||||
compiler.cfg.representations
|
||||
compiler.cfg.representations.preferred
|
||||
compiler.cfg.gc-checks compiler.cfg.save-contexts compiler.cfg ;
|
||||
compiler.cfg.def-use compiler.cfg.rpo
|
||||
compiler.cfg.representations compiler.cfg.gc-checks
|
||||
compiler.cfg.save-contexts compiler.cfg
|
||||
compiler.cfg.representations.preferred ;
|
||||
FROM: compiler.cfg.linearization => number-blocks ;
|
||||
IN: compiler.cfg.debugger
|
||||
|
||||
GENERIC: test-builder ( quot -- cfgs )
|
||||
|
|
@ -28,31 +29,28 @@ M: word test-builder
|
|||
: test-optimizer ( quot -- cfgs )
|
||||
test-builder [ [ optimize-cfg ] with-cfg ] map ;
|
||||
|
||||
: test-ssa ( quot -- mrs )
|
||||
: test-ssa ( quot -- cfgs )
|
||||
test-builder [
|
||||
[
|
||||
optimize-cfg
|
||||
flatten-cfg
|
||||
] with-cfg
|
||||
] map ;
|
||||
|
||||
: test-flat ( quot -- mrs )
|
||||
: test-flat ( quot -- cfgs )
|
||||
test-builder [
|
||||
[
|
||||
optimize-cfg
|
||||
select-representations
|
||||
insert-gc-checks
|
||||
insert-save-contexts
|
||||
flatten-cfg
|
||||
] with-cfg
|
||||
] map ;
|
||||
|
||||
: test-regs ( quot -- mrs )
|
||||
: test-regs ( quot -- cfgs )
|
||||
test-builder [
|
||||
[
|
||||
optimize-cfg
|
||||
finalize-cfg
|
||||
build-mr
|
||||
] with-cfg
|
||||
] map ;
|
||||
|
||||
|
|
@ -64,19 +62,32 @@ M: ##phi insn.
|
|||
|
||||
M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
|
||||
|
||||
: mr. ( mr -- )
|
||||
"=== word: " write
|
||||
dup word>> pprint
|
||||
", label: " write
|
||||
dup label>> pprint nl nl
|
||||
instructions>> [ insn. ] each ;
|
||||
: block. ( bb -- )
|
||||
"=== Basic block #" write dup block-number . nl
|
||||
dup instructions>> [ insn. ] each nl
|
||||
successors>> [
|
||||
"Successors: " write
|
||||
[ block-number unparse ] map ", " join print nl
|
||||
] unless-empty ;
|
||||
|
||||
: mrs. ( mrs -- )
|
||||
[ nl ] [ mr. ] interleave ;
|
||||
: cfg. ( cfg -- )
|
||||
[
|
||||
dup linearization-order number-blocks
|
||||
"=== word: " write
|
||||
dup word>> pprint
|
||||
", label: " write
|
||||
dup label>> pprint nl nl
|
||||
dup linearization-order [ block. ] each
|
||||
"=== stack frame: " write
|
||||
stack-frame>> .
|
||||
] with-scope ;
|
||||
|
||||
: ssa. ( quot -- ) test-ssa mrs. ;
|
||||
: flat. ( quot -- ) test-flat mrs. ;
|
||||
: regs. ( quot -- ) test-regs mrs. ;
|
||||
: cfgs. ( cfgs -- )
|
||||
[ nl ] [ cfg. ] interleave ;
|
||||
|
||||
: ssa. ( quot -- ) test-ssa cfgs. ;
|
||||
: flat. ( quot -- ) test-flat cfgs. ;
|
||||
: regs. ( quot -- ) test-regs cfgs. ;
|
||||
|
||||
! Prettyprinting
|
||||
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
|
|
|||
|
|
@ -19,10 +19,6 @@ M: insn uses-vregs drop { } ;
|
|||
|
||||
M: ##phi uses-vregs inputs>> values ;
|
||||
|
||||
M: _conditional-branch defs-vreg insn>> defs-vreg ;
|
||||
|
||||
M: _conditional-branch uses-vregs insn>> uses-vregs ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: slot-array-quot ( slots -- quot )
|
||||
|
|
@ -59,7 +55,7 @@ PRIVATE>
|
|||
[
|
||||
insn-classes get
|
||||
[ [ define-defs-vreg-method ] each ]
|
||||
[ { ##phi _conditional-branch } diff [ define-uses-vregs-method ] each ]
|
||||
[ { ##phi } diff [ define-uses-vregs-method ] each ]
|
||||
[ [ define-temp-vregs-method ] each ]
|
||||
tri
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
|
||||
compiler.cfg.linear-scan compiler.cfg.representations
|
||||
compiler.cfg.save-contexts compiler.cfg.ssa.destruction ;
|
||||
compiler.cfg.representations compiler.cfg.save-contexts
|
||||
compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
|
||||
compiler.cfg.linear-scan ;
|
||||
IN: compiler.cfg.finalization
|
||||
|
||||
: finalize-cfg ( cfg -- cfg' )
|
||||
|
|
@ -10,4 +11,5 @@ IN: compiler.cfg.finalization
|
|||
insert-gc-checks
|
||||
insert-save-contexts
|
||||
destruct-ssa
|
||||
linear-scan ;
|
||||
linear-scan
|
||||
build-stack-frame ;
|
||||
|
|
|
|||
|
|
@ -67,6 +67,10 @@ literal: word ;
|
|||
INSN: ##jump
|
||||
literal: word ;
|
||||
|
||||
INSN: ##prologue ;
|
||||
|
||||
INSN: ##epilogue ;
|
||||
|
||||
INSN: ##return ;
|
||||
|
||||
! Dummy instruction that simply inhibits TCO
|
||||
|
|
@ -613,16 +617,13 @@ literal: params stack-frame ;
|
|||
INSN: ##alien-callback
|
||||
literal: params stack-frame ;
|
||||
|
||||
! Instructions used by CFG IR only.
|
||||
INSN: ##prologue ;
|
||||
INSN: ##epilogue ;
|
||||
|
||||
INSN: ##branch ;
|
||||
|
||||
! Control flow
|
||||
INSN: ##phi
|
||||
def: dst
|
||||
literal: inputs ;
|
||||
|
||||
INSN: ##branch ;
|
||||
|
||||
! Tagged conditionals
|
||||
INSN: ##compare-branch
|
||||
use: src1/tagged-rep src2/tagged-rep
|
||||
|
|
@ -725,30 +726,6 @@ INSN: ##reload
|
|||
def: dst
|
||||
literal: rep src ;
|
||||
|
||||
! Instructions used by machine IR only.
|
||||
INSN: _spill-area-size
|
||||
literal: n ;
|
||||
|
||||
INSN: _prologue
|
||||
literal: stack-frame ;
|
||||
|
||||
INSN: _epilogue
|
||||
literal: stack-frame ;
|
||||
|
||||
INSN: _label
|
||||
literal: label ;
|
||||
|
||||
INSN: _branch
|
||||
literal: label ;
|
||||
|
||||
INSN: _loop-entry ;
|
||||
|
||||
INSN: _dispatch-label
|
||||
literal: label ;
|
||||
|
||||
INSN: _conditional-branch
|
||||
literal: label insn ;
|
||||
|
||||
UNION: ##allocation
|
||||
##allot
|
||||
##box-alien
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ SYMBOL: unhandled-intervals
|
|||
: reg-class-assoc ( quot -- assoc )
|
||||
[ reg-classes ] dip { } map>assoc ; inline
|
||||
|
||||
: next-spill-slot ( rep -- n )
|
||||
: next-spill-slot ( size -- n )
|
||||
cfg get
|
||||
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
|
||||
<spill-slot> ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ compiler.cfg.liveness
|
|||
compiler.cfg.liveness.ssa
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linearization
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg.renaming.functor
|
||||
compiler.cfg.linearization.order
|
||||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ compiler.cfg.instructions
|
|||
compiler.cfg.registers
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.linearization
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.comparisons
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ compiler.cfg.instructions
|
|||
compiler.cfg.registers
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.linearization.order
|
||||
compiler.cfg.linearization
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg
|
||||
cpu.architecture ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math sequences grouping namespaces
|
||||
compiler.cfg.linearization.order ;
|
||||
compiler.cfg.linearization ;
|
||||
IN: compiler.cfg.linear-scan.numbering
|
||||
|
||||
ERROR: already-numbered insn ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
|
||||
USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
|
||||
kernel accessors sequences sets tools.test namespaces ;
|
||||
IN: compiler.cfg.linearization.order.tests
|
||||
IN: compiler.cfg.linearization.tests
|
||||
|
||||
V{ } 0 test-bb
|
||||
|
||||
|
|
@ -1,74 +1,91 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math accessors sequences namespaces make
|
||||
combinators assocs arrays locals layouts hashtables
|
||||
cpu.architecture generalizations
|
||||
compiler.cfg
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.linearization.order ;
|
||||
USING: accessors arrays assocs deques dlists hashtables kernel
|
||||
make sorting namespaces sequences combinators
|
||||
combinators.short-circuit fry math compiler.cfg.rpo
|
||||
compiler.cfg.utilities compiler.cfg.loop-detection
|
||||
compiler.cfg.predecessors sets hash-sets ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.linearization
|
||||
|
||||
! This is RPO except loops are rotated and unlikely blocks go
|
||||
! at the end. Based on SBCL's src/compiler/control.lisp
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: work-list loop-heads visited ;
|
||||
|
||||
: visited? ( bb -- ? ) visited get in? ;
|
||||
|
||||
: add-to-work-list ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
work-list get push-back
|
||||
] if ;
|
||||
|
||||
: init-linearization-order ( cfg -- )
|
||||
<dlist> work-list set
|
||||
HS{ } clone visited set
|
||||
entry>> add-to-work-list ;
|
||||
|
||||
: (find-alternate-loop-head) ( bb -- bb' )
|
||||
dup {
|
||||
[ predecessor visited? not ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ number>> ] [ predecessor number>> ] bi > ]
|
||||
} 1&& [ predecessor (find-alternate-loop-head) ] when ;
|
||||
|
||||
: find-back-edge ( bb -- pred )
|
||||
[ predecessors>> ] keep '[ _ back-edge? ] find nip ;
|
||||
|
||||
: find-alternate-loop-head ( bb -- bb' )
|
||||
dup find-back-edge dup visited? [ drop ] [
|
||||
nip (find-alternate-loop-head)
|
||||
] if ;
|
||||
|
||||
: predecessors-ready? ( bb -- ? )
|
||||
[ predecessors>> ] keep '[
|
||||
_ 2dup back-edge?
|
||||
[ 2drop t ] [ drop visited? ] if
|
||||
] all? ;
|
||||
|
||||
: process-successor ( bb -- )
|
||||
dup predecessors-ready? [
|
||||
dup loop-entry? [ find-alternate-loop-head ] when
|
||||
add-to-work-list
|
||||
] [ drop ] if ;
|
||||
|
||||
: sorted-successors ( bb -- seq )
|
||||
successors>> <reversed> [ loop-nesting-at ] sort-with ;
|
||||
|
||||
: process-block ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
[ , ]
|
||||
[ visited get adjoin ]
|
||||
[ sorted-successors [ process-successor ] each ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
init-linearization-order
|
||||
|
||||
[ work-list get [ process-block ] slurp-deque ] { } make
|
||||
! [ unlikely?>> not ] partition append
|
||||
;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: linearization-order ( cfg -- bbs )
|
||||
needs-post-order needs-loops needs-predecessors
|
||||
|
||||
dup linear-order>> [ ] [
|
||||
dup (linearization-order)
|
||||
>>linear-order linear-order>>
|
||||
] ?if ;
|
||||
|
||||
SYMBOL: numbers
|
||||
|
||||
: block-number ( bb -- n ) numbers get at ;
|
||||
|
||||
: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
|
||||
|
||||
GENERIC: linearize-insn ( basic-block insn -- )
|
||||
|
||||
M: insn linearize-insn , drop ;
|
||||
|
||||
: useless-branch? ( basic-block successor -- ? )
|
||||
! If our successor immediately follows us in linearization
|
||||
! order then we don't need to branch.
|
||||
[ block-number ] bi@ 1 - = ; inline
|
||||
|
||||
: emit-branch ( bb successor -- )
|
||||
2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
|
||||
|
||||
M: ##branch linearize-insn
|
||||
drop dup successors>> first emit-branch ;
|
||||
|
||||
GENERIC: negate-insn-cc ( insn -- )
|
||||
|
||||
M: conditional-branch-insn negate-insn-cc
|
||||
[ negate-cc ] change-cc drop ;
|
||||
|
||||
M: ##test-vector-branch negate-insn-cc
|
||||
[ negate-vcc ] change-vcc drop ;
|
||||
|
||||
M:: conditional-branch-insn linearize-insn ( bb insn -- )
|
||||
bb successors>> first2 :> ( first second )
|
||||
bb second useless-branch?
|
||||
[ bb second first ]
|
||||
[ bb first second insn negate-insn-cc ] if
|
||||
block-number insn _conditional-branch
|
||||
emit-branch ;
|
||||
|
||||
M: ##dispatch linearize-insn
|
||||
, successors>> [ block-number _dispatch-label ] each ;
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ block-number _label ]
|
||||
[ dup instructions>> [ linearize-insn ] with each ]
|
||||
bi ;
|
||||
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
[
|
||||
[
|
||||
linearization-order
|
||||
[ number-blocks ]
|
||||
[ [ linearize-basic-block ] each ] bi
|
||||
] [ spill-area-size>> _spill-area-size ] bi
|
||||
] { } make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: flatten-cfg ( cfg -- mr )
|
||||
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
|
||||
<mr> ;
|
||||
: number-blocks ( bbs -- )
|
||||
[ 2array ] map-index >hashtable numbers set ;
|
||||
|
|
|
|||
|
|
@ -1,84 +0,0 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists kernel make sorting
|
||||
namespaces sequences combinators combinators.short-circuit
|
||||
fry math compiler.cfg.rpo compiler.cfg.utilities
|
||||
compiler.cfg.loop-detection compiler.cfg.predecessors
|
||||
sets hash-sets ;
|
||||
FROM: namespaces => set ;
|
||||
IN: compiler.cfg.linearization.order
|
||||
|
||||
! This is RPO except loops are rotated and unlikely blocks go
|
||||
! at the end. Based on SBCL's src/compiler/control.lisp
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: work-list loop-heads visited ;
|
||||
|
||||
: visited? ( bb -- ? ) visited get in? ;
|
||||
|
||||
: add-to-work-list ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
work-list get push-back
|
||||
] if ;
|
||||
|
||||
: init-linearization-order ( cfg -- )
|
||||
<dlist> work-list set
|
||||
HS{ } clone visited set
|
||||
entry>> add-to-work-list ;
|
||||
|
||||
: (find-alternate-loop-head) ( bb -- bb' )
|
||||
dup {
|
||||
[ predecessor visited? not ]
|
||||
[ predecessors>> length 1 = ]
|
||||
[ predecessor successors>> length 1 = ]
|
||||
[ [ number>> ] [ predecessor number>> ] bi > ]
|
||||
} 1&& [ predecessor (find-alternate-loop-head) ] when ;
|
||||
|
||||
: find-back-edge ( bb -- pred )
|
||||
[ predecessors>> ] keep '[ _ back-edge? ] find nip ;
|
||||
|
||||
: find-alternate-loop-head ( bb -- bb' )
|
||||
dup find-back-edge dup visited? [ drop ] [
|
||||
nip (find-alternate-loop-head)
|
||||
] if ;
|
||||
|
||||
: predecessors-ready? ( bb -- ? )
|
||||
[ predecessors>> ] keep '[
|
||||
_ 2dup back-edge?
|
||||
[ 2drop t ] [ drop visited? ] if
|
||||
] all? ;
|
||||
|
||||
: process-successor ( bb -- )
|
||||
dup predecessors-ready? [
|
||||
dup loop-entry? [ find-alternate-loop-head ] when
|
||||
add-to-work-list
|
||||
] [ drop ] if ;
|
||||
|
||||
: sorted-successors ( bb -- seq )
|
||||
successors>> <reversed> [ loop-nesting-at ] sort-with ;
|
||||
|
||||
: process-block ( bb -- )
|
||||
dup visited? [ drop ] [
|
||||
[ , ]
|
||||
[ visited get adjoin ]
|
||||
[ sorted-successors [ process-successor ] each ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
: (linearization-order) ( cfg -- bbs )
|
||||
init-linearization-order
|
||||
|
||||
[ work-list get [ process-block ] slurp-deque ] { } make
|
||||
! [ unlikely?>> not ] partition append
|
||||
;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: linearization-order ( cfg -- bbs )
|
||||
needs-post-order needs-loops needs-predecessors
|
||||
|
||||
dup linear-order>> [ ] [
|
||||
dup (linearization-order)
|
||||
>>linear-order linear-order>>
|
||||
] ?if ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Flattening CFG into MR (machine representation)
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.cfg.linearization compiler.cfg.build-stack-frame ;
|
||||
IN: compiler.cfg.mr
|
||||
|
||||
: build-mr ( cfg -- mr )
|
||||
flatten-cfg
|
||||
build-stack-frame ;
|
||||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.order namespaces accessors kernel layouts combinators
|
||||
combinators.smart assocs sequences cpu.architecture ;
|
||||
USING: math math.order namespaces accessors kernel layouts
|
||||
combinators combinators.smart assocs sequences cpu.architecture
|
||||
words compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.stack-frame
|
||||
|
||||
TUPLE: stack-frame
|
||||
{ params integer }
|
||||
{ return integer }
|
||||
{ total-size integer }
|
||||
{ spill-area-size integer }
|
||||
{ total-size integer }
|
||||
{ calls-vm? boolean } ;
|
||||
|
||||
! Stack frame utilities
|
||||
|
|
@ -28,5 +29,11 @@ TUPLE: stack-frame
|
|||
{
|
||||
[ [ params>> ] bi@ max >>params ]
|
||||
[ [ return>> ] bi@ max >>return ]
|
||||
[ [ spill-area-size>> ] bi@ max >>spill-area-size ]
|
||||
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
|
||||
} 2cleave ;
|
||||
} 2cleave ;
|
||||
|
||||
! PowerPC backend sets frame-required? for ##integer>float too
|
||||
\ ##spill t "frame-required?" set-word-prop
|
||||
\ ##unary-float-function t "frame-required?" set-word-prop
|
||||
\ ##binary-float-function t "frame-required?" set-word-prop
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.complex alien.c-types
|
||||
alien.libraries alien.private alien.strings arrays
|
||||
classes.struct combinators compiler.alien
|
||||
compiler.cfg.instructions compiler.codegen
|
||||
compiler.codegen.fixup compiler.errors compiler.utilities
|
||||
cpu.architecture fry kernel layouts libc locals make math
|
||||
math.order math.parser namespaces quotations sequences strings ;
|
||||
FROM: compiler.errors => no-such-symbol ;
|
||||
IN: compiler.codegen.alien
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: next-fastcall-param ( rep -- )
|
||||
|
||||
: ?dummy-stack-params ( rep -- )
|
||||
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-int-params ( rep -- )
|
||||
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-fp-params ( rep -- )
|
||||
drop dummy-fp-params? [ float-regs inc ] when ;
|
||||
|
||||
M: int-rep next-fastcall-param
|
||||
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
|
||||
|
||||
M: float-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
|
||||
M: double-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
|
||||
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
|
||||
|
||||
M: stack-params reg-class-full? 2drop t ;
|
||||
|
||||
M: reg-class reg-class-full?
|
||||
[ get ] swap '[ _ param-regs length ] bi >= ;
|
||||
|
||||
: alloc-stack-param ( rep -- n reg-class rep )
|
||||
stack-params get
|
||||
[ rep-size cell align stack-params +@ ] dip
|
||||
stack-params dup ;
|
||||
|
||||
: alloc-fastcall-param ( rep -- n reg-class rep )
|
||||
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
|
||||
|
||||
:: alloc-parameter ( parameter abi -- reg rep )
|
||||
parameter c-type-rep dup reg-class-of abi reg-class-full?
|
||||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ abi param-reg ] dip ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
<< void* c-type clone \ (stack-value) define-primitive-type
|
||||
stack-params \ (stack-value) c-type (>>rep) >>
|
||||
|
||||
: ((flatten-type)) ( type to-type -- seq )
|
||||
[ stack-size cell align cell /i ] dip c-type <repetition> ; inline
|
||||
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
void* ((flatten-type)) ;
|
||||
: (flatten-stack-type) ( type -- seq )
|
||||
(stack-value) ((flatten-type)) ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type 1array ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align cell /i void* c-type <repetition> % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reset-fastcall-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
||||
: with-param-regs ( quot -- )
|
||||
#! In quot you can call alloc-parameter
|
||||
[ reset-fastcall-counts call ] with-scope ; inline
|
||||
|
||||
: move-parameters ( node word -- )
|
||||
#! Moves values from C stack to registers (if word is
|
||||
#! %load-param-reg) and registers to C stack (if word is
|
||||
#! %save-param-reg).
|
||||
[ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
|
||||
[ '[ _ alloc-parameter _ execute ] ]
|
||||
bi* each-parameter ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
|
||||
|
||||
: prepare-unbox-parameters ( parameters -- offsets types indices )
|
||||
[ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> swap
|
||||
'[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
|
||||
[ length neg %inc-d ]
|
||||
bi ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
#! parameters. If the C function is returning a structure,
|
||||
#! the first parameter is an implicit target area pointer,
|
||||
#! so we need to use a different offset.
|
||||
return>> large-struct?
|
||||
[ %prepare-box-struct cell ] [ 0 ] if ;
|
||||
|
||||
: objects>registers ( params -- )
|
||||
#! Generate code for unboxing a list of C types, then
|
||||
#! generate code for moving these parameters to registers on
|
||||
#! architectures where parameters are passed in registers.
|
||||
[
|
||||
[ prepare-box-struct ] keep
|
||||
[ unbox-parameters ] keep
|
||||
\ %load-param-reg move-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return %push-stack ] if-void ;
|
||||
|
||||
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
|
||||
|
||||
M: string dlsym-valid? dlsym ;
|
||||
|
||||
M: array dlsym-valid? '[ _ dlsym ] any? ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd dlsym-valid?
|
||||
[ drop ] [ compiling-word get no-such-symbol ] if
|
||||
] [
|
||||
dll-path compiling-word get no-such-library drop
|
||||
] if ;
|
||||
|
||||
: decorated-symbol ( params -- symbols )
|
||||
[ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
|
||||
{
|
||||
[ drop ]
|
||||
[ "@" glue ]
|
||||
[ "@" glue "_" prepend ]
|
||||
[ "@" glue "@" prepend ]
|
||||
} 2cleave
|
||||
4array ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
|
||||
[ library>> load-library ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
M: ##alien-invoke generate-insn
|
||||
params>>
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call function
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
! Box return value
|
||||
dup %cleanup
|
||||
box-return* ;
|
||||
|
||||
M: ##alien-assembly generate-insn
|
||||
params>>
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Generate assembly
|
||||
dup quot>> call( -- )
|
||||
! Box return value
|
||||
box-return* ;
|
||||
|
||||
! ##alien-indirect
|
||||
M: ##alien-indirect generate-insn
|
||||
params>>
|
||||
! 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
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
! Generate code for boxing input parameters in a callback.
|
||||
[
|
||||
dup \ %save-param-reg move-parameters
|
||||
%begin-callback
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup void? ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: callback-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: wrap-callback-quot ( params -- quot )
|
||||
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
|
||||
yield-hook get
|
||||
'[ _ _ do-callback ]
|
||||
>quotation ;
|
||||
|
||||
M: ##alien-callback generate-insn
|
||||
params>>
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -2,23 +2,20 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make math math.order math.parser sequences
|
||||
accessors kernel layouts assocs words summary arrays combinators
|
||||
classes.algebra alien alien.private alien.c-types alien.strings
|
||||
alien.arrays alien.complex alien.libraries sets libc
|
||||
continuations.private fry cpu.architecture classes
|
||||
classes.struct locals source-files.errors slots parser
|
||||
generic.parser strings quotations
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
classes.algebra sets continuations.private fry cpu.architecture
|
||||
classes classes.struct locals slots parser generic.parser
|
||||
strings quotations hashtables
|
||||
compiler.constants
|
||||
compiler.cfg
|
||||
compiler.cfg.linearization
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.comparisons
|
||||
compiler.cfg.stack-frame
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.builder
|
||||
compiler.codegen.fixup
|
||||
compiler.utilities ;
|
||||
FROM: namespaces => set ;
|
||||
FROM: compiler.errors => no-such-symbol ;
|
||||
IN: compiler.codegen
|
||||
|
||||
SYMBOL: insn-counts
|
||||
|
|
@ -27,40 +24,88 @@ H{ } clone insn-counts set-global
|
|||
|
||||
GENERIC: generate-insn ( insn -- )
|
||||
|
||||
! Mapping _label IDs to label instances
|
||||
! Control flow
|
||||
SYMBOL: labels
|
||||
|
||||
: lookup-label ( id -- label )
|
||||
: lookup-label ( bb -- label )
|
||||
labels get [ drop <label> ] cache ;
|
||||
|
||||
: generate ( mr -- code )
|
||||
dup label>> [
|
||||
H{ } clone labels set
|
||||
: useless-branch? ( bb successor -- ? )
|
||||
! If our successor immediately follows us in linearization
|
||||
! order then we don't need to branch.
|
||||
[ block-number ] bi@ 1 - = ; inline
|
||||
|
||||
: emit-branch ( bb successor -- )
|
||||
2dup useless-branch?
|
||||
[ 2drop ] [ nip lookup-label %jump-label ] if ;
|
||||
|
||||
M: ##branch generate-insn
|
||||
drop basic-block get dup successors>> first emit-branch ;
|
||||
|
||||
GENERIC: generate-conditional-insn ( label insn -- )
|
||||
|
||||
GENERIC: negate-insn-cc ( insn -- )
|
||||
|
||||
M: conditional-branch-insn negate-insn-cc
|
||||
[ negate-cc ] change-cc drop ;
|
||||
|
||||
M: ##test-vector-branch negate-insn-cc
|
||||
[ negate-vcc ] change-vcc drop ;
|
||||
|
||||
M:: conditional-branch-insn generate-insn ( insn -- )
|
||||
basic-block get :> bb
|
||||
bb successors>> first2 :> ( first second )
|
||||
bb second useless-branch?
|
||||
[ bb second first ]
|
||||
[ bb first second insn negate-insn-cc ] if
|
||||
lookup-label insn generate-conditional-insn
|
||||
emit-branch ;
|
||||
|
||||
: %dispatch-label ( label -- )
|
||||
cell 0 <repetition> %
|
||||
rc-absolute-cell label-fixup ;
|
||||
|
||||
M: ##dispatch generate-insn
|
||||
[ src>> ] [ temp>> ] bi %dispatch
|
||||
basic-block get successors>>
|
||||
[ lookup-label %dispatch-label ] each ;
|
||||
|
||||
: generate-block ( bb -- )
|
||||
[ basic-block set ]
|
||||
[ lookup-label resolve-label ]
|
||||
[
|
||||
instructions>> [
|
||||
[ class insn-counts get inc-at ]
|
||||
[ generate-insn ]
|
||||
bi
|
||||
] each
|
||||
] tri ;
|
||||
|
||||
: generate ( cfg -- code )
|
||||
dup label>> [
|
||||
H{ } clone labels set
|
||||
linearization-order
|
||||
[ number-blocks ] [ [ generate-block ] each ] bi
|
||||
] with-fixup ;
|
||||
|
||||
! Special cases
|
||||
M: ##no-tco generate-insn drop ;
|
||||
|
||||
M: _prologue generate-insn
|
||||
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
|
||||
M: ##prologue generate-insn
|
||||
drop
|
||||
cfg get stack-frame>>
|
||||
[ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
|
||||
|
||||
M: _epilogue generate-insn
|
||||
stack-frame>> total-size>> %epilogue ;
|
||||
|
||||
M: _spill-area-size generate-insn drop ;
|
||||
M: ##epilogue generate-insn
|
||||
drop
|
||||
cfg get stack-frame>> [ total-size>> %epilogue ] when* ;
|
||||
|
||||
! Some meta-programming to generate simple code generators, where
|
||||
! the instruction is unpacked and then a %word is called
|
||||
<<
|
||||
|
||||
: insn-slot-quot ( spec -- quot )
|
||||
name>> [ reader-word ] [ "label" = ] bi
|
||||
[ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
|
||||
name>> reader-word 1quotation ;
|
||||
|
||||
: codegen-method-body ( class word -- quot )
|
||||
[
|
||||
|
|
@ -204,18 +249,6 @@ CODEGEN: ##alien-global %alien-global
|
|||
CODEGEN: ##call-gc %call-gc
|
||||
CODEGEN: ##spill %spill
|
||||
CODEGEN: ##reload %reload
|
||||
CODEGEN: ##dispatch %dispatch
|
||||
|
||||
: %dispatch-label ( label -- )
|
||||
cell 0 <repetition> %
|
||||
rc-absolute-cell label-fixup ;
|
||||
|
||||
CODEGEN: _label resolve-label
|
||||
CODEGEN: _dispatch-label %dispatch-label
|
||||
CODEGEN: _branch %jump-label
|
||||
CODEGEN: _loop-entry %loop-entry
|
||||
|
||||
GENERIC: generate-conditional-insn ( label insn -- )
|
||||
|
||||
<<
|
||||
|
||||
|
|
@ -236,226 +269,3 @@ CONDITIONAL: ##check-nursery-branch %check-nursery-branch
|
|||
CONDITIONAL: ##fixnum-add %fixnum-add
|
||||
CONDITIONAL: ##fixnum-sub %fixnum-sub
|
||||
CONDITIONAL: ##fixnum-mul %fixnum-mul
|
||||
|
||||
M: _conditional-branch generate-insn
|
||||
[ label>> lookup-label ] [ insn>> ] bi generate-conditional-insn ;
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: next-fastcall-param ( rep -- )
|
||||
|
||||
: ?dummy-stack-params ( rep -- )
|
||||
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-int-params ( rep -- )
|
||||
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: ?dummy-fp-params ( rep -- )
|
||||
drop dummy-fp-params? [ float-regs inc ] when ;
|
||||
|
||||
M: int-rep next-fastcall-param
|
||||
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
|
||||
|
||||
M: float-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
|
||||
M: double-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
|
||||
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
|
||||
|
||||
M: stack-params reg-class-full? 2drop t ;
|
||||
|
||||
M: reg-class reg-class-full?
|
||||
[ get ] swap '[ _ param-regs length ] bi >= ;
|
||||
|
||||
: alloc-stack-param ( rep -- n reg-class rep )
|
||||
stack-params get
|
||||
[ rep-size cell align stack-params +@ ] dip
|
||||
stack-params dup ;
|
||||
|
||||
: alloc-fastcall-param ( rep -- n reg-class rep )
|
||||
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
|
||||
|
||||
:: alloc-parameter ( parameter abi -- reg rep )
|
||||
parameter c-type-rep dup reg-class-of abi reg-class-full?
|
||||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ abi param-reg ] dip ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
<< void* c-type clone \ (stack-value) define-primitive-type
|
||||
stack-params \ (stack-value) c-type (>>rep) >>
|
||||
|
||||
: ((flatten-type)) ( type to-type -- seq )
|
||||
[ stack-size cell align cell /i ] dip c-type <repetition> ; inline
|
||||
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
void* ((flatten-type)) ;
|
||||
: (flatten-stack-type) ( type -- seq )
|
||||
(stack-value) ((flatten-type)) ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type 1array ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align cell /i void* c-type <repetition> % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reset-fastcall-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
||||
: with-param-regs ( quot -- )
|
||||
#! In quot you can call alloc-parameter
|
||||
[ reset-fastcall-counts call ] with-scope ; inline
|
||||
|
||||
: move-parameters ( node word -- )
|
||||
#! Moves values from C stack to registers (if word is
|
||||
#! %load-param-reg) and registers to C stack (if word is
|
||||
#! %save-param-reg).
|
||||
[ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
|
||||
[ '[ _ alloc-parameter _ execute ] ]
|
||||
bi* each-parameter ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
|
||||
|
||||
: prepare-unbox-parameters ( parameters -- offsets types indices )
|
||||
[ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> swap
|
||||
'[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
|
||||
[ length neg %inc-d ]
|
||||
bi ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
#! parameters. If the C function is returning a structure,
|
||||
#! the first parameter is an implicit target area pointer,
|
||||
#! so we need to use a different offset.
|
||||
return>> large-struct?
|
||||
[ %prepare-box-struct cell ] [ 0 ] if ;
|
||||
|
||||
: objects>registers ( params -- )
|
||||
#! Generate code for unboxing a list of C types, then
|
||||
#! generate code for moving these parameters to registers on
|
||||
#! architectures where parameters are passed in registers.
|
||||
[
|
||||
[ prepare-box-struct ] keep
|
||||
[ unbox-parameters ] keep
|
||||
\ %load-param-reg move-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return %push-stack ] if-void ;
|
||||
|
||||
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
|
||||
|
||||
M: string dlsym-valid? dlsym ;
|
||||
|
||||
M: array dlsym-valid? '[ _ dlsym ] any? ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd dlsym-valid?
|
||||
[ drop ] [ compiling-word get no-such-symbol ] if
|
||||
] [
|
||||
dll-path compiling-word get no-such-library drop
|
||||
] if ;
|
||||
|
||||
: decorated-symbol ( params -- symbols )
|
||||
[ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
|
||||
{
|
||||
[ drop ]
|
||||
[ "@" glue ]
|
||||
[ "@" glue "_" prepend ]
|
||||
[ "@" glue "@" prepend ]
|
||||
} 2cleave
|
||||
4array ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
|
||||
[ library>> load-library ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
M: ##alien-invoke generate-insn
|
||||
params>>
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call function
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
! Box return value
|
||||
dup %cleanup
|
||||
box-return* ;
|
||||
|
||||
M: ##alien-assembly generate-insn
|
||||
params>>
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Generate assembly
|
||||
dup quot>> call( -- )
|
||||
! Box return value
|
||||
box-return* ;
|
||||
|
||||
! ##alien-indirect
|
||||
M: ##alien-indirect generate-insn
|
||||
params>>
|
||||
! 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
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
! Generate code for boxing input parameters in a callback.
|
||||
[
|
||||
dup \ %save-param-reg move-parameters
|
||||
%begin-callback
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup void? ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: callback-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: wrap-callback-quot ( params -- quot )
|
||||
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
|
||||
yield-hook get
|
||||
'[ _ _ do-callback ]
|
||||
>quotation ;
|
||||
|
||||
M: ##alien-callback generate-insn
|
||||
params>>
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
|
||||
|
|
|
|||
|
|
@ -17,9 +17,9 @@ compiler.cfg
|
|||
compiler.cfg.builder
|
||||
compiler.cfg.optimizer
|
||||
compiler.cfg.finalization
|
||||
compiler.cfg.mr
|
||||
|
||||
compiler.codegen ;
|
||||
compiler.codegen
|
||||
compiler.codegen.alien ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: compiled
|
||||
|
|
@ -126,8 +126,10 @@ M: word combinator? inline? ;
|
|||
|
||||
: backend ( tree word -- )
|
||||
build-cfg [
|
||||
[ optimize-cfg finalize-cfg build-mr ] with-cfg
|
||||
[ generate ] [ label>> ] bi compiled get set-at
|
||||
[
|
||||
optimize-cfg finalize-cfg
|
||||
[ generate ] [ label>> ] bi compiled get set-at
|
||||
] with-cfg
|
||||
] each ;
|
||||
|
||||
: compile-word ( word -- )
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
USING: accessors assocs compiler compiler.cfg
|
||||
compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
|
||||
compiler.cfg.debugger compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.linear-scan
|
||||
compiler.cfg.ssa.destruction compiler.codegen compiler.units
|
||||
cpu.architecture hashtables kernel namespaces sequences
|
||||
tools.test vectors words layouts literals math arrays
|
||||
alien.c-types alien.syntax math.private ;
|
||||
compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
|
||||
compiler.codegen compiler.units cpu.architecture hashtables
|
||||
kernel namespaces sequences tools.test vectors words layouts
|
||||
literals math arrays alien.c-types alien.syntax math.private ;
|
||||
IN: compiler.tests.low-level-ir
|
||||
|
||||
: compile-cfg ( cfg -- word )
|
||||
gensym
|
||||
[ linear-scan build-mr generate ] dip
|
||||
[ linear-scan build-stack-frame generate ] dip
|
||||
[ associate >alist t t modify-code-heap ] keep ;
|
||||
|
||||
: compile-test-cfg ( -- word )
|
||||
|
|
|
|||
|
|
@ -5,10 +5,11 @@ arrays kernel fry math namespaces sequences system layouts io
|
|||
vocabs.loader accessors init classes.struct combinators
|
||||
command-line make words compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame cpu.x86.assembler
|
||||
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
|
||||
compiler.codegen.alien compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
|
||||
cpu.architecture vm ;
|
||||
FROM: layouts => cell ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue