From f5c5d8b44cf7b3f87a7623af3263349dfd8f6717 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 2 May 2010 18:48:41 -0400 Subject: [PATCH] compiler: remove flat machine representation and generate code directly from the CFG --- .../build-stack-frame.factor | 47 +-- .../compiler/cfg/builder/builder-tests.factor | 21 +- basis/compiler/cfg/cfg.factor | 9 +- basis/compiler/cfg/checker/checker.factor | 17 +- basis/compiler/cfg/debugger/debugger.factor | 55 +-- basis/compiler/cfg/def-use/def-use.factor | 6 +- .../cfg/finalization/finalization.factor | 8 +- .../cfg/instructions/instructions.factor | 37 +- .../linear-scan/allocation/state/state.factor | 2 +- .../linear-scan/assignment/assignment.factor | 2 +- .../cfg/linear-scan/linear-scan-tests.factor | 1 - .../live-intervals/live-intervals.factor | 2 +- .../linear-scan/numbering/numbering.factor | 2 +- ...ests.factor => linearization-tests.factor} | 4 +- .../cfg/linearization/linearization.factor | 147 ++++---- .../cfg/linearization/order/order.factor | 84 ----- basis/compiler/cfg/linearization/summary.txt | 1 - basis/compiler/cfg/mr/authors.txt | 1 - basis/compiler/cfg/mr/mr.factor | 8 - .../cfg/stack-frame/stack-frame.factor | 15 +- basis/compiler/codegen/alien/alien.factor | 231 +++++++++++++ basis/compiler/codegen/alien/authors.txt | 1 + basis/compiler/codegen/codegen.factor | 322 ++++-------------- basis/compiler/compiler.factor | 10 +- basis/compiler/tests/low-level-ir.factor | 12 +- basis/cpu/x86/32/32.factor | 9 +- 26 files changed, 488 insertions(+), 566 deletions(-) rename basis/compiler/cfg/linearization/{order/order-tests.factor => linearization-tests.factor} (83%) delete mode 100644 basis/compiler/cfg/linearization/order/order.factor delete mode 100644 basis/compiler/cfg/linearization/summary.txt delete mode 100644 basis/compiler/cfg/mr/authors.txt delete mode 100644 basis/compiler/cfg/mr/mr.factor create mode 100644 basis/compiler/codegen/alien/alien.factor create mode 100644 basis/compiler/codegen/alien/authors.txt diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 49dfb95164..8f98ab7add 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -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 ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index b8fde7fef6..5d2c5e2e3c 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -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 diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 1391c37077..c49d638509 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -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 ; - -: ( instructions word label -- mr ) - mr new - swap >>label - swap >>word - swap >>instructions ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index b84742b8b0..d7a48a1511 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -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 ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 0d74531961..dc0be45cc0 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -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 -- ) > pprint* block> ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index a576a54884..93c1a53b44 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 ; - [ 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 diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 24097d63a4..3ee7ba06e3 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index e483b707ae..d4e019d8dd 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index f9e6fc6a36..89ec1b7785 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index b160bd776c..1682cf9eb6 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index eb2dc2d64d..9e6ec76d2c 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 9766bb62d1..cb697c2136 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 44b2ff907a..391edf21d6 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -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 ; diff --git a/basis/compiler/cfg/linearization/order/order-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor similarity index 83% rename from basis/compiler/cfg/linearization/order/order-tests.factor rename to basis/compiler/cfg/linearization/linearization-tests.factor index 67fb55f507..edaeb720c7 100644 --- a/basis/compiler/cfg/linearization/order/order-tests.factor +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -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 diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9c3a0068bc..c44b29d271 100644 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -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 + 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>> [ 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 - ; +: number-blocks ( bbs -- ) + [ 2array ] map-index >hashtable numbers set ; diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor deleted file mode 100644 index a68a90a8e8..0000000000 --- a/basis/compiler/cfg/linearization/order/order.factor +++ /dev/null @@ -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 - - 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>> [ 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 ; diff --git a/basis/compiler/cfg/linearization/summary.txt b/basis/compiler/cfg/linearization/summary.txt deleted file mode 100644 index 96daec8046..0000000000 --- a/basis/compiler/cfg/linearization/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Flattening CFG into MR (machine representation) diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/mr/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor deleted file mode 100644 index 5b9e9ee2c3..0000000000 --- a/basis/compiler/cfg/mr/mr.factor +++ /dev/null @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 5861ca67bd..8ad55d76d8 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -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 ; \ 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 diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor new file mode 100644 index 0000000000..5123b1c62c --- /dev/null +++ b/basis/compiler/codegen/alien/alien.factor @@ -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 ; 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 % ] 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 ] 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 ; diff --git a/basis/compiler/codegen/alien/authors.txt b/basis/compiler/codegen/alien/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/codegen/alien/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 4737f1a47d..604fb2570e 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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