! 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?
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 ;
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
] 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
TUPLE: cfg { entry basic-block } word label
spill-area-size
+stack-frame
post-order linear-order
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 ;
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
[ 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 ;
-! 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
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 )
: 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 ;
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 ;
-
-: ssa. ( quot -- ) test-ssa mrs. ;
-: flat. ( quot -- ) test-flat mrs. ;
-: regs. ( quot -- ) test-regs mrs. ;
+: 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 ;
+
+: 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> ;
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 )
[
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
! 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' )
insert-gc-checks
insert-save-contexts
destruct-ssa
- linear-scan ;
+ linear-scan
+ build-stack-frame ;
INSN: ##jump
literal: word ;
+INSN: ##prologue ;
+
+INSN: ##epilogue ;
+
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
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
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
: 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> ;
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 ;
compiler.cfg.registers
compiler.cfg.predecessors
compiler.cfg.rpo
-compiler.cfg.linearization
compiler.cfg.debugger
compiler.cfg.def-use
compiler.cfg.comparisons
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 ;
! 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 ;
--- /dev/null
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
+kernel accessors sequences sets tools.test namespaces ;
+IN: compiler.cfg.linearization.tests
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 { 1 1 } edges
+1 2 edge
+
+[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
-! 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
-<PRIVATE
-
-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
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
-: 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 ;
+<PRIVATE
-M: ##test-vector-branch negate-insn-cc
- [ negate-vcc ] change-vcc drop ;
+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
+ ;
-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 ;
+PRIVATE>
-M: ##dispatch linearize-insn
- , successors>> [ block-number _dispatch-label ] each ;
+: linearization-order ( cfg -- bbs )
+ needs-post-order needs-loops needs-predecessors
-: linearize-basic-block ( bb -- )
- [ block-number _label ]
- [ dup instructions>> [ linearize-insn ] with each ]
- bi ;
+ dup linear-order>> [ ] [
+ dup (linearization-order)
+ >>linear-order linear-order>>
+ ] ?if ;
-: linearize-basic-blocks ( cfg -- insns )
- [
- [
- linearization-order
- [ number-blocks ]
- [ [ linearize-basic-block ] each ] bi
- ] [ spill-area-size>> _spill-area-size ] bi
- ] { } make ;
+SYMBOL: numbers
-PRIVATE>
+: block-number ( bb -- n ) numbers get at ;
-: flatten-cfg ( cfg -- mr )
- [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
- <mr> ;
+: number-blocks ( bbs -- )
+ [ 2array ] map-index >hashtable numbers set ;
+++ /dev/null
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
-kernel accessors sequences sets tools.test namespaces ;
-IN: compiler.cfg.linearization.order.tests
-
-V{ } 0 test-bb
-
-V{ } 1 test-bb
-
-V{ } 2 test-bb
-
-0 { 1 1 } edges
-1 2 edge
-
-[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test
+++ /dev/null
-! 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 ;
+++ /dev/null
-Flattening CFG into MR (machine representation)
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! 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 ;
\ No newline at end of file
! 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
{
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
+ [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
- } 2cleave ;
\ No newline at end of file
+ } 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
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+Slava Pestov
! 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
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: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
+M: ##prologue generate-insn
+ drop
+ cfg get stack-frame>>
+ [ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
-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 )
[
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 -- )
<<
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 ;
compiler.cfg.builder
compiler.cfg.optimizer
compiler.cfg.finalization
-compiler.cfg.mr
-compiler.codegen ;
+compiler.codegen
+compiler.codegen.alien ;
IN: compiler
SYMBOL: compiled
: 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 -- )
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 )
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
projects / factor.git / commitdiff