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

compiler: remove flat machine representation and generate code directly from the CFG

db4
Slava Pestov 2010-05-02 18:48:41 -04:00
parent 5236f327ba
commit f5c5d8b44c
26 changed files with 488 additions and 566 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture layouts combinators classes words cpu.architecture layouts compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.stack-frame ; compiler.cfg.registers compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required? SYMBOL: frame-required?
@ -30,43 +30,24 @@ M: ##call-gc compute-stack-frame*
frame-required? on frame-required? on
stack-frame new t >>calls-vm? request-stack-frame ; 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* M: insn compute-stack-frame*
class frame-required? word-prop [ class "frame-required?" word-prop
frame-required? on [ frame-required? on ] when ;
] when ;
! PowerPC backend sets frame-required? for ##integer>float! : initial-stack-frame ( -- stack-frame )
\ ##spill t frame-required? set-word-prop stack-frame new cfg get spill-area-size>> >>spill-area-size ;
\ ##unary-float-function t frame-required? set-word-prop
\ ##binary-float-function t frame-required? set-word-prop
: compute-stack-frame ( insns -- ) : compute-stack-frame ( insns -- )
frame-required? off frame-required? off
stack-frame new stack-frame set initial-stack-frame stack-frame set
[ compute-stack-frame* ] each [ instructions>> [ compute-stack-frame* ] each ] each-basic-block
stack-frame get dup stack-frame-size >>total-size drop ; stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- ) : build-stack-frame ( cfg -- cfg )
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 )
[
[ [
[ compute-stack-frame ] [ compute-stack-frame ]
[ insert-pro/epilogues ] [
bi frame-required? get stack-frame get f ?
] change-instructions >>stack-frame
] bi
] with-scope ; ] with-scope ;

21
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -1,12 +1,13 @@
USING: tools.test kernel sequences words sequences.private fry USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder prettyprint alien alien.accessors math.private
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.tree.builder compiler.tree.optimizer
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker compiler.cfg.builder compiler.cfg.debugger
compiler.cfg arrays locals byte-arrays kernel.private math compiler.cfg.optimizer compiler.cfg.rpo
slots.private vectors sbufs strings math.partial-dispatch compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
hashtables assocs combinators.short-circuit arrays locals byte-arrays kernel.private math slots.private
strings.private accessors compiler.cfg.instructions vectors sbufs strings math.partial-dispatch hashtables assocs
compiler.cfg.representations ; combinators.short-circuit strings.private accessors
compiler.cfg.instructions compiler.cfg.representations ;
FROM: alien.c-types => int ; FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests IN: compiler.cfg.builder.tests
@ -161,8 +162,8 @@ IN: compiler.cfg.builder.tests
] each ] each
: count-insns ( quot insn-check -- ? ) : count-insns ( quot insn-check -- ? )
[ test-regs [ instructions>> ] map ] dip [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
'[ _ count ] map-sum ; inline count ; inline
: contains-insn? ( quot insn-check -- ? ) : contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline count-insns 0 > ; inline

9
basis/compiler/cfg/cfg.factor
View File

@ -22,6 +22,7 @@ M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label TUPLE: cfg { entry basic-block } word label
spill-area-size spill-area-size
stack-frame
post-order linear-order post-order linear-order
predecessors-valid? dominance-valid? loops-valid? ; 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 ) : with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline [ 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 ;

17
basis/compiler/cfg/checker/checker.factor
View File

@ -3,7 +3,7 @@
USING: kernel combinators.short-circuit accessors math sequences USING: kernel combinators.short-circuit accessors math sequences
sets assocs compiler.cfg.instructions compiler.cfg.rpo sets assocs compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.def-use compiler.cfg.linearization
compiler.cfg.utilities compiler.cfg.finalization compiler.cfg.mr compiler.cfg.utilities compiler.cfg.finalization
compiler.utilities ; compiler.utilities ;
IN: compiler.cfg.checker IN: compiler.cfg.checker
@ -52,18 +52,5 @@ ERROR: bad-successors ;
[ check-successors ] [ check-successors ]
bi ; 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-cfg ( cfg -- )
[ [ check-basic-block ] each-basic-block ] [ check-basic-block ] each-basic-block ;
[ finalize-cfg build-mr check-mr ]
bi ;

47
basis/compiler/cfg/debugger/debugger.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors USING: kernel words sequences quotations namespaces io vectors
arrays hashtables classes.tuple accessors prettyprint 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.stack-frame compiler.cfg.linear-scan
compiler.cfg.optimizer compiler.cfg.finalization compiler.cfg.optimizer compiler.cfg.finalization
compiler.cfg.instructions compiler.cfg.utilities compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr compiler.cfg.def-use compiler.cfg.rpo
compiler.cfg.representations compiler.cfg.representations compiler.cfg.gc-checks
compiler.cfg.representations.preferred compiler.cfg.save-contexts compiler.cfg
compiler.cfg.gc-checks compiler.cfg.save-contexts compiler.cfg ; compiler.cfg.representations.preferred ;
FROM: compiler.cfg.linearization => number-blocks ;
IN: compiler.cfg.debugger IN: compiler.cfg.debugger
GENERIC: test-builder ( quot -- cfgs ) GENERIC: test-builder ( quot -- cfgs )
@ -28,31 +29,28 @@ M: word test-builder
: test-optimizer ( quot -- cfgs ) : test-optimizer ( quot -- cfgs )
test-builder [ [ optimize-cfg ] with-cfg ] map ; test-builder [ [ optimize-cfg ] with-cfg ] map ;
: test-ssa ( quot -- mrs ) : test-ssa ( quot -- cfgs )
test-builder [ test-builder [
[ [
optimize-cfg optimize-cfg
flatten-cfg
] with-cfg ] with-cfg
] map ; ] map ;
: test-flat ( quot -- mrs ) : test-flat ( quot -- cfgs )
test-builder [ test-builder [
[ [
optimize-cfg optimize-cfg
select-representations select-representations
insert-gc-checks insert-gc-checks
insert-save-contexts insert-save-contexts
flatten-cfg
] with-cfg ] with-cfg
] map ; ] map ;
: test-regs ( quot -- mrs ) : test-regs ( quot -- cfgs )
test-builder [ test-builder [
[ [
optimize-cfg optimize-cfg
finalize-cfg finalize-cfg
build-mr
] with-cfg ] with-cfg
] map ; ] map ;
@ -64,19 +62,32 @@ M: ##phi insn.
M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ; M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
: mr. ( mr -- ) : 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 ;
: cfg. ( cfg -- )
[
dup linearization-order number-blocks
"=== word: " write "=== word: " write
dup word>> pprint dup word>> pprint
", label: " write ", label: " write
dup label>> pprint nl nl dup label>> pprint nl nl
instructions>> [ insn. ] each ; dup linearization-order [ block. ] each
"=== stack frame: " write
stack-frame>> .
] with-scope ;
: mrs. ( mrs -- ) : cfgs. ( cfgs -- )
[ nl ] [ mr. ] interleave ; [ nl ] [ cfg. ] interleave ;
: ssa. ( quot -- ) test-ssa mrs. ; : ssa. ( quot -- ) test-ssa cfgs. ;
: flat. ( quot -- ) test-flat mrs. ; : flat. ( quot -- ) test-flat cfgs. ;
: regs. ( quot -- ) test-regs mrs. ; : regs. ( quot -- ) test-regs cfgs. ;
! Prettyprinting ! Prettyprinting
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ; : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;

6
basis/compiler/cfg/def-use/def-use.factor
View File

@ -19,10 +19,6 @@ M: insn uses-vregs drop { } ;
M: ##phi uses-vregs inputs>> values ; M: ##phi uses-vregs inputs>> values ;
M: _conditional-branch defs-vreg insn>> defs-vreg ;
M: _conditional-branch uses-vregs insn>> uses-vregs ;
<PRIVATE <PRIVATE
: slot-array-quot ( slots -- quot ) : slot-array-quot ( slots -- quot )
@ -59,7 +55,7 @@ PRIVATE>
[ [
insn-classes get insn-classes get
[ [ define-defs-vreg-method ] each ] [ [ 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 ] [ [ define-temp-vregs-method ] each ]
tri tri
] with-compilation-unit ] with-compilation-unit

8
basis/compiler/cfg/finalization/finalization.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2010 Slava Pestov. ! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
compiler.cfg.linear-scan compiler.cfg.representations compiler.cfg.representations compiler.cfg.save-contexts
compiler.cfg.save-contexts compiler.cfg.ssa.destruction ; compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
compiler.cfg.linear-scan ;
IN: compiler.cfg.finalization IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' ) : finalize-cfg ( cfg -- cfg' )
@ -10,4 +11,5 @@ IN: compiler.cfg.finalization
insert-gc-checks insert-gc-checks
insert-save-contexts insert-save-contexts
destruct-ssa destruct-ssa
linear-scan ; linear-scan
build-stack-frame ;

37
basis/compiler/cfg/instructions/instructions.factor
View File

@ -67,6 +67,10 @@ literal: word ;
INSN: ##jump INSN: ##jump
literal: word ; literal: word ;
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##return ; INSN: ##return ;
! Dummy instruction that simply inhibits TCO ! Dummy instruction that simply inhibits TCO
@ -613,16 +617,13 @@ literal: params stack-frame ;
INSN: ##alien-callback INSN: ##alien-callback
literal: params stack-frame ; literal: params stack-frame ;
! Instructions used by CFG IR only. ! Control flow
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##phi INSN: ##phi
def: dst def: dst
literal: inputs ; literal: inputs ;
INSN: ##branch ;
! Tagged conditionals ! Tagged conditionals
INSN: ##compare-branch INSN: ##compare-branch
use: src1/tagged-rep src2/tagged-rep use: src1/tagged-rep src2/tagged-rep
@ -725,30 +726,6 @@ INSN: ##reload
def: dst def: dst
literal: rep src ; 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 UNION: ##allocation
##allot ##allot
##box-alien ##box-alien

2
basis/compiler/cfg/linear-scan/allocation/state/state.factor
View File

@ -117,7 +117,7 @@ SYMBOL: unhandled-intervals
: reg-class-assoc ( quot -- assoc ) : reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline [ reg-classes ] dip { } map>assoc ; inline
: next-spill-slot ( rep -- n ) : next-spill-slot ( size -- n )
cfg get cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ; <spill-slot> ;

2
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -9,9 +9,9 @@ compiler.cfg.liveness
compiler.cfg.liveness.ssa compiler.cfg.liveness.ssa
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linearization
compiler.cfg.ssa.destruction compiler.cfg.ssa.destruction
compiler.cfg.renaming.functor compiler.cfg.renaming.functor
compiler.cfg.linearization.order
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;

1
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -8,7 +8,6 @@ compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.predecessors compiler.cfg.predecessors
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger compiler.cfg.debugger
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.comparisons compiler.cfg.comparisons

2
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -6,7 +6,7 @@ compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.linearization.order compiler.cfg.linearization
compiler.cfg.ssa.destruction compiler.cfg.ssa.destruction
compiler.cfg compiler.cfg
cpu.architecture ; cpu.architecture ;

2
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences grouping namespaces USING: kernel accessors math sequences grouping namespaces
compiler.cfg.linearization.order ; compiler.cfg.linearization ;
IN: compiler.cfg.linear-scan.numbering IN: compiler.cfg.linear-scan.numbering
ERROR: already-numbered insn ; ERROR: already-numbered insn ;

4
basis/compiler/cfg/linearization/order/order-tests.factor → basis/compiler/cfg/linearization/linearization-tests.factor
View File

@ -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 ; kernel accessors sequences sets tools.test namespaces ;
IN: compiler.cfg.linearization.order.tests IN: compiler.cfg.linearization.tests
V{ } 0 test-bb V{ } 0 test-bb

147
basis/compiler/cfg/linearization/linearization.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make USING: accessors arrays assocs deques dlists hashtables kernel
combinators assocs arrays locals layouts hashtables make sorting namespaces sequences combinators
cpu.architecture generalizations combinators.short-circuit fry math compiler.cfg.rpo
compiler.cfg compiler.cfg.utilities compiler.cfg.loop-detection
compiler.cfg.comparisons compiler.cfg.predecessors sets hash-sets ;
compiler.cfg.stack-frame FROM: namespaces => set ;
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization 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 <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 SYMBOL: numbers
: block-number ( bb -- n ) numbers get at ; : block-number ( bb -- n ) numbers get at ;
: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ; : 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> ;

84
basis/compiler/cfg/linearization/order/order.factor
View File

@ -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
basis/compiler/cfg/linearization/summary.txt
View File

@ -1 +0,0 @@
Flattening CFG into MR (machine representation)

1
basis/compiler/cfg/mr/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

8
basis/compiler/cfg/mr/mr.factor
View File

@ -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 ;

13
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math math.order namespaces accessors kernel layouts combinators USING: math math.order namespaces accessors kernel layouts
combinators.smart assocs sequences cpu.architecture ; combinators combinators.smart assocs sequences cpu.architecture
words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame IN: compiler.cfg.stack-frame
TUPLE: stack-frame TUPLE: stack-frame
{ params integer } { params integer }
{ return integer } { return integer }
{ total-size integer }
{ spill-area-size integer } { spill-area-size integer }
{ total-size integer }
{ calls-vm? boolean } ; { calls-vm? boolean } ;
! Stack frame utilities ! Stack frame utilities
@ -28,5 +29,11 @@ TUPLE: stack-frame
{ {
[ [ params>> ] bi@ max >>params ] [ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ] [ [ return>> ] bi@ max >>return ]
[ [ spill-area-size>> ] bi@ max >>spill-area-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ] [ [ 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

231
basis/compiler/codegen/alien/alien.factor Normal file
View File

@ -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 ;

1
basis/compiler/codegen/alien/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

322
basis/compiler/codegen/codegen.factor
View File

@ -2,23 +2,20 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences USING: namespaces make math math.order math.parser sequences
accessors kernel layouts assocs words summary arrays combinators accessors kernel layouts assocs words summary arrays combinators
classes.algebra alien alien.private alien.c-types alien.strings classes.algebra sets continuations.private fry cpu.architecture
alien.arrays alien.complex alien.libraries sets libc classes classes.struct locals slots parser generic.parser
continuations.private fry cpu.architecture classes strings quotations hashtables
classes.struct locals source-files.errors slots parser
generic.parser strings quotations
compiler.errors
compiler.alien
compiler.constants compiler.constants
compiler.cfg compiler.cfg
compiler.cfg.linearization
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.comparisons
compiler.cfg.stack-frame compiler.cfg.stack-frame
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.builder compiler.cfg.builder
compiler.codegen.fixup compiler.codegen.fixup
compiler.utilities ; compiler.utilities ;
FROM: namespaces => set ; FROM: namespaces => set ;
FROM: compiler.errors => no-such-symbol ;
IN: compiler.codegen IN: compiler.codegen
SYMBOL: insn-counts SYMBOL: insn-counts
@ -27,40 +24,88 @@ H{ } clone insn-counts set-global
GENERIC: generate-insn ( insn -- ) GENERIC: generate-insn ( insn -- )
! Mapping _label IDs to label instances ! Control flow
SYMBOL: labels SYMBOL: labels
: lookup-label ( id -- label ) : lookup-label ( bb -- label )
labels get [ drop <label> ] cache ; labels get [ drop <label> ] cache ;
: generate ( mr -- code ) : useless-branch? ( bb successor -- ? )
dup label>> [ ! If our successor immediately follows us in linearization
H{ } clone labels set ! 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>> [ instructions>> [
[ class insn-counts get inc-at ] [ class insn-counts get inc-at ]
[ generate-insn ] [ generate-insn ]
bi bi
] each ] each
] tri ;
: generate ( cfg -- code )
dup label>> [
H{ } clone labels set
linearization-order
[ number-blocks ] [ [ generate-block ] each ] bi
] with-fixup ; ] with-fixup ;
! Special cases ! Special cases
M: ##no-tco generate-insn drop ; M: ##no-tco generate-insn drop ;
M: _prologue generate-insn M: ##prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ; drop
cfg get stack-frame>>
[ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
M: _epilogue generate-insn M: ##epilogue generate-insn
stack-frame>> total-size>> %epilogue ; drop
cfg get stack-frame>> [ total-size>> %epilogue ] when* ;
M: _spill-area-size generate-insn drop ;
! Some meta-programming to generate simple code generators, where ! Some meta-programming to generate simple code generators, where
! the instruction is unpacked and then a %word is called ! the instruction is unpacked and then a %word is called
<< <<
: insn-slot-quot ( spec -- quot ) : insn-slot-quot ( spec -- quot )
name>> [ reader-word ] [ "label" = ] bi name>> reader-word 1quotation ;
[ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
: codegen-method-body ( class word -- quot ) : codegen-method-body ( class word -- quot )
[ [
@ -204,18 +249,6 @@ CODEGEN: ##alien-global %alien-global
CODEGEN: ##call-gc %call-gc CODEGEN: ##call-gc %call-gc
CODEGEN: ##spill %spill CODEGEN: ##spill %spill
CODEGEN: ##reload %reload 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-add %fixnum-add
CONDITIONAL: ##fixnum-sub %fixnum-sub CONDITIONAL: ##fixnum-sub %fixnum-sub
CONDITIONAL: ##fixnum-mul %fixnum-mul 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 ;

8
basis/compiler/compiler.factor
View File

@ -17,9 +17,9 @@ compiler.cfg
compiler.cfg.builder compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.optimizer
compiler.cfg.finalization compiler.cfg.finalization
compiler.cfg.mr
compiler.codegen ; compiler.codegen
compiler.codegen.alien ;
IN: compiler IN: compiler
SYMBOL: compiled SYMBOL: compiled
@ -126,8 +126,10 @@ M: word combinator? inline? ;
: backend ( tree word -- ) : backend ( tree word -- )
build-cfg [ build-cfg [
[ optimize-cfg finalize-cfg build-mr ] with-cfg [
optimize-cfg finalize-cfg
[ generate ] [ label>> ] bi compiled get set-at [ generate ] [ label>> ] bi compiled get set-at
] with-cfg
] each ; ] each ;
: compile-word ( word -- ) : compile-word ( word -- )

12
basis/compiler/tests/low-level-ir.factor
View File

@ -1,15 +1,15 @@
USING: accessors assocs compiler compiler.cfg 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.registers compiler.cfg.linear-scan
compiler.cfg.ssa.destruction compiler.codegen compiler.units compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
cpu.architecture hashtables kernel namespaces sequences compiler.codegen compiler.units cpu.architecture hashtables
tools.test vectors words layouts literals math arrays kernel namespaces sequences tools.test vectors words layouts
alien.c-types alien.syntax math.private ; literals math arrays alien.c-types alien.syntax math.private ;
IN: compiler.tests.low-level-ir IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word ) : compile-cfg ( cfg -- word )
gensym gensym
[ linear-scan build-mr generate ] dip [ linear-scan build-stack-frame generate ] dip
[ associate >alist t t modify-code-heap ] keep ; [ associate >alist t t modify-code-heap ] keep ;
: compile-test-cfg ( -- word ) : compile-test-cfg ( -- word )

9
basis/cpu/x86/32/32.factor
View File

@ -5,10 +5,11 @@ arrays kernel fry math namespaces sequences system layouts io
vocabs.loader accessors init classes.struct combinators vocabs.loader accessors init classes.struct combinators
command-line make words compiler compiler.units command-line make words compiler compiler.units
compiler.constants compiler.alien compiler.codegen compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions compiler.codegen.alien compiler.codegen.fixup
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.stack-frame cpu.x86.assembler compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ; cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture vm ;
FROM: layouts => cell ; FROM: layouts => cell ;
IN: cpu.x86.32 IN: cpu.x86.32