-USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis compiler.cfg.debugger
-cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests
-
-[ ] [
- {
- T{ ##peek f V int-regs 2 D 1 f }
- T{ ##box-alien f V int-regs 1 V int-regs 2 }
- T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
- } alias-analysis drop
-] unit-test
-
-[ ] [
- {
- T{ ##load-reference f V int-regs 1 "hello" }
- T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
- } alias-analysis drop
-] unit-test
-
-[
- {
- T{ ##peek f V int-regs 1 D 1 f }
- T{ ##peek f V int-regs 2 D 2 f }
- T{ ##replace f V int-regs 1 D 0 f }
- }
-] [
- {
- T{ ##peek f V int-regs 1 D 1 f }
- T{ ##peek f V int-regs 2 D 2 f }
- T{ ##replace f V int-regs 2 D 0 f }
- T{ ##replace f V int-regs 1 D 0 f }
- } alias-analysis
-] unit-test
-
-[
- {
- T{ ##peek f V int-regs 1 D 1 f }
- T{ ##peek f V int-regs 2 D 0 f }
- T{ ##copy f V int-regs 3 V int-regs 2 f }
- T{ ##copy f V int-regs 4 V int-regs 1 f }
- T{ ##replace f V int-regs 3 D 0 f }
- T{ ##replace f V int-regs 4 D 1 f }
- }
-] [
- {
- T{ ##peek f V int-regs 1 D 1 f }
- T{ ##peek f V int-regs 2 D 0 f }
- T{ ##replace f V int-regs 1 D 0 f }
- T{ ##replace f V int-regs 2 D 1 f }
- T{ ##peek f V int-regs 3 D 1 f }
- T{ ##peek f V int-regs 4 D 0 f }
- T{ ##replace f V int-regs 3 D 0 f }
- T{ ##replace f V int-regs 4 D 1 f }
- } alias-analysis
-] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop ;
+compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.alias-analysis
-! Alias analysis -- assumes compiler.cfg.height has already run.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
+! We try to eliminate redundant slot operations using some simple heuristics.
!
! All heap-allocated objects which are loaded from the stack, or
! other object slots are pessimistically assumed to belong to
!
! Freshly-allocated objects get their own alias class.
!
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-!
! Simple pseudo-C example showing load elimination:
!
! int *x, *y, z: inputs
! Map vregs -> alias classes
SYMBOL: vregs>acs
-: check ( obj -- obj )
- [ "BUG: static type error detected" throw ] unless* ; inline
-
+ERROR: vreg-ac-not-set vreg ;
+
: vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
- vregs>acs get at check ;
+ vregs>acs get ?at [ vreg-ac-not-set ] unless ;
! Map alias classes -> sequence of vregs
SYMBOL: acs>vregs
#! value.
over [ live-slots get at at ] [ 2drop f ] if ;
+ERROR: vreg-has-no-slots vreg ;
+
: load-constant-slot ( value slot# vreg -- )
- live-slots get at check set-at ;
+ live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
: load-slot ( value slot#/f vreg -- )
over [ load-constant-slot ] [ 3drop ] if ;
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
-M: ##peek insn-slot# loc>> n>> ;
-M: ##replace insn-slot# loc>> n>> ;
M: ##slot insn-slot# slot>> constant ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##peek insn-object loc>> class ;
-M: ##replace insn-object loc>> class ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
-: init-alias-analysis ( -- )
+: init-alias-analysis ( live-in -- )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone constants set
H{ } clone copies set
-
+
0 ac-counter set
next-ac heap-ac set
- ds-loc next-ac set-ac
- rs-loc next-ac set-ac ;
+ [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##load-reference analyze-aliases*
+M: ##flushable analyze-aliases*
dup dst>> set-heap-ac ;
-M: ##alien-global analyze-aliases*
- dup dst>> set-heap-ac ;
-
-M: ##allot analyze-aliases*
- #! A freshly allocated object is distinct from any other
- #! object.
- dup dst>> set-new-ac ;
-
-M: ##box-float analyze-aliases*
- #! A freshly allocated object is distinct from any other
- #! object.
- dup dst>> set-new-ac ;
-
-M: ##box-alien analyze-aliases*
+M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##read analyze-aliases*
- dup dst>> set-heap-ac
+ call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
- 2nip f \ ##copy boa analyze-aliases* nip
+ 2nip \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
] unless
] when ;
-M: ##replace eliminate-dead-stores*
- #! Writes to above the top of the stack can be pruned also.
- #! This is sound since any such writes are not observable
- #! after the basic block, and any reads of those locations
- #! will have been converted to copies by analyze-slot,
- #! and the final stack height of the basic block is set at
- #! the beginning by compiler.cfg.stack.
- dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
-
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
-: alias-analysis ( insns -- insns' )
- init-alias-analysis
+: alias-analysis-step ( insns -- insns' )
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
+
+: alias-analysis ( cfg -- cfg' )
+ [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
basic-block get successors>> push
stop-iterating ;
-: emit-call ( word -- next )
+: emit-call ( word height -- next )
{
- { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+ { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
+ { [ terminate-call? ] [ ##call stop-iterating ] }
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
- { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
- [ ##epilogue ##jump stop-iterating ]
+ { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
+ [ drop ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
-: compile-recursive ( node -- next )
- [ label>> id>> emit-call ]
+: recursive-height ( #recursive -- n )
+ [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-recursive ( #recursive -- next )
+ [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
-: compile-loop ( node -- next )
+: emit-loop ( node -- next )
##loop-entry
+ ##branch
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
M: #recursive emit-node
- dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+ dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if
: emit-branch ( obj -- final-bb )
} cond iterate-next ;
! #dispatch
-: trivial-dispatch-branch? ( nodes -- ? )
- dup length 1 = [
- first dup #call? [
- word>> "intrinsic" word-prop not
- ] [ drop f ] if
- ] [ drop f ] if ;
-
-: dispatch-branch ( nodes word -- label )
- over trivial-dispatch-branch? [
- drop first word>>
- ] [
- gensym [
- [
- V{ } clone node-stack set
- ##prologue
- begin-basic-block
- emit-nodes
- basic-block get [
- ##epilogue
- ##return
- end-basic-block
- ] when
- ] with-cfg-builder
- ] keep
- ] if ;
-
-: dispatch-branches ( node -- )
- children>> [
- current-word get dispatch-branch
- ##dispatch-label
- ] each ;
-
-: emit-dispatch ( node -- )
- ##epilogue
- ds-pop ^^offset>slot i 0 ##dispatch
- dispatch-branches ;
-
-: <dispatch-block> ( -- word )
- gensym dup t "inlined-block" set-word-prop ;
-
M: #dispatch emit-node
- tail-call? [
- emit-dispatch stop-iterating
- ] [
- current-word get <dispatch-block> [
- [
- begin-word
- emit-dispatch
- ] with-cfg-builder
- ] keep emit-call
- ] if ;
+ ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ nip emit-call ] if ;
+ [ emit-intrinsic ] [ swap call-height emit-call ] if ;
! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
! #push
M: #push emit-node
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors namespaces ;
+USING: kernel arrays vectors accessors
+namespaces make fry sequences ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
{ successors vector }
{ predecessors vector } ;
-: <basic-block> ( -- basic-block )
+M: basic-block hashcode* nip id>> ;
+
+: <basic-block> ( -- bb )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors
\ basic-block counter >>id ;
-TUPLE: cfg { entry basic-block } word label ;
+: add-instructions ( bb quot -- )
+ [ instructions>> building ] dip '[
+ building get pop
+ _ dip
+ building get push
+ ] with-variable ; inline
+
+TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
-C: <cfg> cfg
+: <cfg> ( entry word label -- cfg ) f f cfg boa ;
-TUPLE: mr { instructions array } word label spill-counts ;
+TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )
mr new
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+combinators.short-circuit accessors math sequences sets assocs ;
+IN: compiler.cfg.checker
+
+ERROR: last-insn-not-a-jump insn ;
+
+: check-last-instruction ( bb -- )
+ last dup {
+ [ ##branch? ]
+ [ ##dispatch? ]
+ [ ##conditional-branch? ]
+ [ ##compare-imm-branch? ]
+ [ ##return? ]
+ [ ##callback-return? ]
+ [ ##jump? ]
+ [ ##call? ]
+ } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
+
+ERROR: bad-loop-entry ;
+
+: check-loop-entry ( bb -- )
+ dup length 2 >= [
+ 2 head* [ ##loop-entry? ] any?
+ [ bad-loop-entry ] when
+ ] [ drop ] if ;
+
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+ dup successors>> [ predecessors>> memq? ] with all?
+ [ bad-successors ] unless ;
+
+: check-basic-block ( bb -- )
+ [ instructions>> check-last-instruction ]
+ [ instructions>> check-loop-entry ]
+ [ check-successors ]
+ tri ;
+
+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 ]
+ [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+ 2dup subset? [ 2drop ] [ undefined-values ] if ;
+
+: check-cfg ( cfg -- )
+ compute-liveness
+ [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
+ [ [ check-basic-block ] each-basic-block ]
+ [ flatten-cfg check-mr ]
+ tri ;
SYMBOL: copies
: resolve ( vreg -- vreg )
- dup copies get at swap or ;
+ [ copies get at ] keep or ;
: record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use
+compiler.cfg.rpo ;
+IN: compiler.cfg.dce
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+: init-dead-code ( -- )
+ H{ } clone liveness-graph set
+ H{ } clone live-vregs set ;
+
+GENERIC: update-liveness-graph ( insn -- )
+
+M: ##flushable update-liveness-graph
+ [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+: record-live ( vregs -- )
+ [
+ dup live-vregs get key? [ drop ] [
+ [ live-vregs get conjoin ]
+ [ liveness-graph get at record-live ]
+ bi
+ ] if
+ ] each ;
+
+M: insn update-liveness-graph uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( cfg -- cfg' )
+ init-dead-code
+ [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+ [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
+ [ ]
+ tri ;
\ No newline at end of file
+++ /dev/null
-USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture tools.test ;
-IN: compiler.cfg.dead-code.tests
-
-[ { } ] [
- { T{ ##load-immediate f V int-regs 134 16 } }
- eliminate-dead-code
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.def-use ;
-IN: compiler.cfg.dead-code
-
-! Dead code elimination -- assumes compiler.cfg.alias-analysis
-! has already run.
-
-! Maps vregs to sequences of vregs
-SYMBOL: liveness-graph
-
-! vregs which participate in side effects and thus are always live
-SYMBOL: live-vregs
-
-! mapping vregs to stack locations
-SYMBOL: vregs>locs
-
-: init-dead-code ( -- )
- H{ } clone liveness-graph set
- H{ } clone live-vregs set
- H{ } clone vregs>locs set ;
-
-GENERIC: compute-liveness ( insn -- )
-
-M: ##flushable compute-liveness
- [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
-
-M: ##peek compute-liveness
- [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
- [ call-next-method ]
- bi ;
-
-: live-replace? ( ##replace -- ? )
- [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
-
-M: ##replace compute-liveness
- dup live-replace? [ call-next-method ] [ drop ] if ;
-
-: record-live ( vregs -- )
- [
- dup live-vregs get key? [ drop ] [
- [ live-vregs get conjoin ]
- [ liveness-graph get at record-live ]
- bi
- ] if
- ] each ;
-
-M: insn compute-liveness uses-vregs record-live ;
-
-GENERIC: live-insn? ( insn -- ? )
-
-M: ##flushable live-insn? dst>> live-vregs get key? ;
-
-M: ##replace live-insn? live-replace? ;
-
-M: insn live-insn? drop t ;
-
-: eliminate-dead-code ( insns -- insns' )
- init-dead-code
- [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
+++ /dev/null
-Dead-code elimination
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer ;
+compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.mr ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: word test-cfg
[ build-tree optimize-tree ] keep build-cfg ;
-SYMBOL: allocate-registers?
-
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
- convert-two-operand
- allocate-registers? get
- [ linear-scan build-stack-frame ] when
] map ;
: insn. ( insn -- )
- tuple>array allocate-registers? get [ but-last ] unless
- [ pprint bl ] each nl ;
+ tuple>array [ pprint bl ] each nl ;
: mr. ( mrs -- )
[
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
+GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ;
-M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp defs-vregs dst/tmp-vregs ;
-M: ##allot defs-vregs dst/tmp-vregs ;
-M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs dst/tmp-vregs ;
+M: ##unary/temp defs-vregs dst>> 1array ;
+M: ##allot defs-vregs dst>> 1array ;
+M: ##slot defs-vregs dst>> 1array ;
M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst/tmp-vregs ;
-M: ##set-string-nth-fast defs-vregs temp>> 1array ;
-M: ##compare defs-vregs dst/tmp-vregs ;
-M: ##compare-imm defs-vregs dst/tmp-vregs ;
-M: ##compare-float defs-vregs dst/tmp-vregs ;
-M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##string-nth defs-vregs dst>> 1array ;
+M: ##compare defs-vregs dst>> 1array ;
+M: ##compare-imm defs-vregs dst>> 1array ;
+M: ##compare-float defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
+M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp temp-vregs temp>> 1array ;
+M: ##allot temp-vregs temp>> 1array ;
+M: ##dispatch temp-vregs temp>> 1array ;
+M: ##slot temp-vregs temp>> 1array ;
+M: ##set-slot temp-vregs temp>> 1array ;
+M: ##string-nth temp-vregs temp>> 1array ;
+M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##compare temp-vregs temp>> 1array ;
+M: ##compare-imm temp-vregs temp>> 1array ;
+M: ##compare-float temp-vregs temp>> 1array ;
+M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch temp-vregs temp>> 1array ;
+M: insn temp-vregs drop f ;
+
M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##phi uses-vregs inputs>> ;
+M: ##gc uses-vregs live-in>> ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: _dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ;
+! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
##fixnum-overflow
##conditional-branch
##compare-imm-branch
+##phi
+##gc
_conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.rpo
+compiler.cfg.stack-analysis fry kernel math.order namespaces
+sequences ;
+IN: compiler.cfg.dominance
+
+! Reference:
+
+! A Simple, Fast Dominance Algorithm
+! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
+! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+
+SYMBOL: idoms
+
+: idom ( bb -- bb' ) idoms get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+ 2dup [ number>> ] compare {
+ { +lt+ [ [ idom ] dip intersect ] }
+ { +gt+ [ idom intersect ] }
+ [ 2drop ]
+ } case ;
+
+: compute-idom ( bb -- idom )
+ predecessors>> [ idom ] map sift
+ [ ] [ intersect ] map-reduce ;
+
+: iterate ( rpo -- changed? )
+ [ [ compute-idom ] keep set-idom ] map [ ] any? ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- cfg )
+ H{ } clone idoms set
+ dup reverse-post-order
+ unclip dup set-idom drop '[ _ iterate ] loop ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs
+cpu.architecture compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.instructions ;
+IN: compiler.cfg.gc-checks
+
+: gc? ( bb -- ? )
+ instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+ live-in keys [ reg-class>> int-regs eq? ] filter ;
+
+: insert-gc-check ( basic-block -- )
+ dup gc? [
+ dup
+ [ swap object-pointer-regs \ ##gc new-insn prefix ]
+ change-instructions drop
+ ] [ drop ] if ;
+
+: insert-gc-checks ( cfg -- cfg' )
+ dup [ insert-gc-check ] each-basic-block ;
\ No newline at end of file
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
+
+: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
M: insn normalize-height* ;
-: normalize-height ( insns -- insns' )
+: height-step ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
- rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
+ ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
+ rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+
+: normalize-height ( cfg -- cfg' )
+ [ drop ] [ height-step ] local-optimization ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
+: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-reference ;
-INSN: ##peek < ##read { loc loc } ;
-INSN: ##replace < ##write { loc loc } ;
+INSN: ##peek < ##flushable { loc loc } ;
+INSN: ##replace < ##effect { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
spill-counts ;
INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word { height integer } ;
INSN: ##jump word ;
INSN: ##return ;
! Jump tables
-INSN: ##dispatch src temp offset ;
-INSN: ##dispatch-label label ;
+INSN: ##dispatch src temp ;
! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ;
+
+UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+
INSN: ##write-barrier < ##effect card# table ;
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##loop-entry ;
+INSN: ##phi < ##pure inputs ;
+
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
+INSN: ##gc live-in ;
+
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ;
INSN: _label id ;
-INSN: _gc ;
-
INSN: _branch label ;
+INSN: _dispatch src temp ;
+INSN: _dispatch-label label ;
+
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
INSN: _compare-branch < _conditional-branch ;
"insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect in>> but-last f <effect> ;
+ boa-effect in>> 2 head* f <effect> ;
SYNTAX: INSN:
- parse-tuple-definition "regs" suffix
+ parse-tuple-definition { "regs" "insn#" } append
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
- [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
+ [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
- [ t ] [
- [ (tail-call?) ]
- [ first #terminate? not ]
- bi and
- ] if-empty
+ [ t ] [ (tail-call?) ] if-empty
] all? ;
+
+: terminate-call? ( -- ? )
+ node-stack get last
+ rest-slice [ f ] [ first #terminate? ] if-empty ;
! but since we never have too many machine registers (around 30
! at most) and we probably won't have that many live at any one
! time anyway, it is not a problem to check each element.
-SYMBOL: active-intervals
+TUPLE: active-intervals seq ;
: add-active ( live-interval -- )
- active-intervals get push ;
+ active-intervals get seq>> push ;
: lookup-register ( vreg -- reg )
- active-intervals get [ vreg>> = ] with find nip reg>> ;
+ active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
: expire-old-intervals ( n -- )
active-intervals get
- swap '[ end>> _ = ] partition
- active-intervals set
+ [ swap '[ end>> _ = ] partition ] change-seq drop
[ insert-spill ] each ;
: insert-reload ( live-interval -- )
] [ 2drop ] if
] if ;
-GENERIC: (assign-registers) ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
-M: vreg-insn (assign-registers)
- dup
- [ defs-vregs ] [ uses-vregs ] bi append
- active-intervals get swap '[ vreg>> _ member? ] filter
+: all-vregs ( insn -- vregs )
+ [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
+
+M: vreg-insn assign-registers-in-insn
+ active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
-M: insn (assign-registers) drop ;
+M: insn assign-registers-in-insn drop ;
+
+: <active-intervals> ( -- obj )
+ V{ } clone active-intervals boa ;
: init-assignment ( live-intervals -- )
- V{ } clone active-intervals set
+ <active-intervals> active-intervals set
<min-heap> unhandled-intervals set
init-unhandled ;
-: assign-registers ( insns live-intervals -- insns' )
+: assign-registers-in-block ( bb -- )
[
- init-assignment
[
- [ activate-new-intervals ]
- [ drop [ (assign-registers) ] [ , ] bi ]
- [ expire-old-intervals ]
- tri
- ] each-index
- ] { } make ;
+ [
+ [ insn#>> activate-new-intervals ]
+ [ [ assign-registers-in-insn ] [ , ] bi ]
+ [ insn#>> expire-old-intervals ]
+ tri
+ ] each
+ ] V{ } make
+ ] change-instructions drop ;
+
+: assign-registers ( rpo live-intervals -- )
+ init-assignment
+ [ assign-registers-in-block ] each ;
kernel fry arrays splitting namespaces math accessors vectors
math.order grouping
cpu.architecture
+compiler.cfg
+compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.linear-scan
USING: math.private compiler.cfg.debugger ;
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+[ ] [
+ [ float+ float>fixnum 3 fixnum*fast ]
+ test-cfg first optimize-cfg linear-scan drop
+] unit-test
[ f ] [
- T{ ##allot
- f
- T{ vreg f int-regs 1 }
- 40
- array
- T{ vreg f int-regs 2 }
- f
- } clone
- 1array (linear-scan) first regs>> values all-equal?
+ T{ basic-block
+ { instructions
+ V{
+ T{ ##allot
+ f
+ T{ vreg f int-regs 1 }
+ 40
+ array
+ T{ vreg f int-regs 2 }
+ f
+ }
+ }
+ }
+ } clone [ [ clone ] map ] change-instructions
+ dup 1array (linear-scan) instructions>> first regs>> values all-equal?
] unit-test
[ 0 1 ] [
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make
cpu.architecture
compiler.cfg
+compiler.cfg.rpo
compiler.cfg.instructions
+compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-: (linear-scan) ( insns -- insns' )
+: (linear-scan) ( rpo -- )
+ dup number-instructions
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
-: linear-scan ( mr -- mr' )
+: linear-scan ( cfg -- cfg' )
[
- [
- [
- (linear-scan) %
- spill-counts get _spill-counts
- ] { } make
- ] change-instructions
+ dup reverse-post-order (linear-scan)
+ spill-counts get >>spill-counts
] with-scope ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers
[ [ <live-interval> ] keep ] dip set-at
] if ;
-GENERIC# compute-live-intervals* 1 ( insn n -- )
+GENERIC: compute-live-intervals* ( insn -- )
-M: insn compute-live-intervals* 2drop ;
+M: insn compute-live-intervals* drop ;
M: vreg-insn compute-live-intervals*
+ dup insn#>>
live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
- 3bi ;
+ [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+ 3tri ;
: record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals*
- [ call-next-method ] [ drop record-copy ] 2bi ;
+ [ call-next-method ] [ record-copy ] bi ;
M: ##copy-float compute-live-intervals*
- [ call-next-method ] [ drop record-copy ] 2bi ;
+ [ call-next-method ] [ record-copy ] bi ;
-: compute-live-intervals ( instructions -- live-intervals )
+: compute-live-intervals ( rpo -- live-intervals )
H{ } clone [
live-intervals set
- [ compute-live-intervals* ] each-index
+ [ instructions>> [ compute-live-intervals* ] each ] each
] keep values ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math sequences ;
+IN: compiler.cfg.linear-scan.numbering
+
+: number-instructions ( rpo -- )
+ [ 0 ] dip [
+ instructions>> [
+ [ (>>insn#) ] [ drop 2 + ] 2bi
+ ] each
+ ] each drop ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
-combinators classes
+combinators assocs
+cpu.architecture
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.liveness
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
-: linearize-insns ( basic-block -- )
- dup instructions>> [ linearize-insn ] with each ; inline
+: linearize-basic-block ( bb -- )
+ [ number>> _label ]
+ [ dup instructions>> [ linearize-insn ] with each ]
+ bi ;
M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we
#! don't need to branch.
- [ number>> ] bi@ 1- = ; inline
+ [ number>> ] bi@ 1 - = ; inline
: branch-to-branch? ( successor -- ? )
#! A branch to a block containing just a jump return is cloned.
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+ { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
[ nip number>> _branch ]
} cond ;
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
+: with-regs ( insn quot -- )
+ over regs>> [ call ] dip building get last (>>regs) ; inline
+
M: ##compare-branch linearize-insn
- binary-conditional _compare-branch emit-branch ;
+ [ binary-conditional _compare-branch ] with-regs emit-branch ;
M: ##compare-imm-branch linearize-insn
- binary-conditional _compare-imm-branch emit-branch ;
+ [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
M: ##compare-float-branch linearize-insn
- binary-conditional _compare-float-branch emit-branch ;
-
-: gc? ( bb -- ? )
- instructions>> [
- class {
- ##allot
- ##integer>bignum
- ##box-float
- ##box-alien
- } memq?
- ] any? ;
-
-: linearize-basic-block ( bb -- )
- [ number>> _label ]
- [ gc? [ _gc ] when ]
- [ linearize-insns ]
- tri ;
-
-: linearize-basic-blocks ( rpo -- insns )
- [ [ linearize-basic-block ] each ] { } make ;
-
-: build-mr ( cfg -- mr )
- [ entry>> reverse-post-order linearize-basic-blocks ]
- [ word>> ] [ label>> ]
- tri <mr> ;
+ [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+
+M: ##dispatch linearize-insn
+ swap
+ [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
+ [ successors>> [ number>> _dispatch-label ] each ]
+ bi* ;
+
+: linearize-basic-blocks ( cfg -- insns )
+ [
+ [ [ linearize-basic-block ] each-basic-block ]
+ [ spill-counts>> _spill-counts ]
+ bi
+ ] { } make ;
+
+: flatten-cfg ( cfg -- mr )
+ [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
+ <mr> ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo ;
+IN: compiler.cfg.liveness
+
+! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-ins
+
+: live-in ( basic-block -- set ) live-ins get at ;
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in conrrespondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set )
+ [ predecessors>> index ] keep phi-live-ins get at
+ dup [ nth ] [ 2drop f ] if ;
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-outs
+
+: live-out ( basic-block -- set ) live-outs get at ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( basic-blocks -- )
+ work-list get '[ _ push-front ] each ;
+
+: map-unique ( seq quot -- assoc )
+ map concat unique ; inline
+
+: gen-set ( instructions -- seq )
+ [ ##phi? not ] filter [ uses-vregs ] map-unique ;
+
+: kill-set ( instructions -- seq )
+ [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
+
+: compute-live-in ( basic-block -- live-in )
+ dup instructions>>
+ [ [ live-out ] [ gen-set ] bi* assoc-union ]
+ [ nip kill-set ]
+ 2bi assoc-diff ;
+
+: compute-phi-live-in ( basic-block -- phi-live-in )
+ instructions>> [ ##phi? ] filter
+ [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
+
+: update-live-in ( basic-block -- changed? )
+ [ [ compute-live-in ] keep live-ins get maybe-set-at ]
+ [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+ bi and ;
+
+: compute-live-out ( basic-block -- live-out )
+ [ successors>> [ live-in ] map ]
+ [ dup successors>> [ phi-live-in ] with map ] bi
+ append assoc-combine ;
+
+: update-live-out ( basic-block -- changed? )
+ [ compute-live-out ] keep
+ live-outs get maybe-set-at ;
+
+: liveness-step ( basic-block -- )
+ dup update-live-out [
+ dup update-live-in
+ [ predecessors>> add-to-work-list ] [ drop ] if
+ ] [ drop ] if ;
+
+: compute-liveness ( cfg -- cfg' )
+ <hashed-dlist> work-list set
+ H{ } clone live-ins set
+ H{ } clone phi-live-ins set
+ H{ } clone live-outs set
+ dup post-order add-to-work-list
+ work-list get [ liveness-step ] slurp-deque ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
+IN: compiler.cfg.local
+
+: optimize-basic-block ( bb init-quot insn-quot -- )
+ [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+
+: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+ [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.cfg.rpo ;
+IN: compiler.cfg.mr
+
+: build-mr ( cfg -- mr )
+ convert-two-operand
+ compute-liveness
+ insert-gc-checks
+ linear-scan
+ flatten-cfg
+ build-stack-frame ;
\ No newline at end of file
--- /dev/null
+USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+sequences.private math sbufs math.private slots.private strings ;
+IN: compiler.cfg.optimizer.tests
+
+! Miscellaneous tests
+
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+ test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
+{
+ [ 1array ]
+ [ 1 2 ? ]
+ [ { array } declare [ ] map ]
+ [ { array } declare dup 1 slot [ 1 slot ] when ]
+ [ [ dup more? ] [ dup ] produce ]
+ [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+ [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+ [
+ { fixnum sbuf } declare 2dup 3 slot fixnum> [
+ over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+ ] [ ] if
+ ]
+ [ [ 2 fixnum* ] when 3 ]
+ [ [ 2 fixnum+ ] when 3 ]
+ [ [ 2 fixnum- ] when 3 ]
+ [ 10000 [ ] times ]
+} [
+ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+] each
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.cfg.rpo
-compiler.cfg.instructions
+USING: kernel sequences accessors combinators namespaces
compiler.cfg.predecessors
compiler.cfg.useless-blocks
compiler.cfg.height
+compiler.cfg.stack-analysis
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
-compiler.cfg.dead-code
-compiler.cfg.write-barrier ;
+compiler.cfg.dce
+compiler.cfg.write-barrier
+compiler.cfg.liveness
+compiler.cfg.rpo
+compiler.cfg.phi-elimination ;
IN: compiler.cfg.optimizer
-: trivial? ( insns -- ? )
- dup length 2 = [ first ##call? ] [ drop f ] if ;
-
: optimize-cfg ( cfg -- cfg' )
- compute-predecessors
- delete-useless-blocks
- delete-useless-conditionals
[
- dup trivial? [
- normalize-height
- alias-analysis
- value-numbering
- eliminate-dead-code
- eliminate-write-barriers
- ] unless
- ] change-basic-blocks ;
+ compute-predecessors
+ delete-useless-blocks
+ delete-useless-conditionals
+ normalize-height
+ stack-analysis
+ compute-liveness
+ alias-analysis
+ value-numbering
+ eliminate-dead-code
+ eliminate-write-barriers
+ eliminate-phis
+ ] with-scope ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo fry kernel sequences ;
+IN: compiler.cfg.phi-elimination
+
+: insert-copy ( predecessor input output -- )
+ '[ _ _ swap ##copy ] add-instructions ;
+
+: eliminate-phi ( bb ##phi -- )
+ [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
+ '[ _ insert-copy ] 2each ;
+
+: eliminate-phi-step ( bb -- )
+ dup [
+ [ ##phi? ] partition
+ [ [ eliminate-phi ] with each ] dip
+ ] change-instructions drop ;
+
+: eliminate-phis ( cfg -- cfg' )
+ dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors
-: (compute-predecessors) ( bb -- )
+: predecessors-step ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' )
- dup [ (compute-predecessors) ] each-basic-block ;
+ dup [ predecessors-step ] each-basic-block ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ;
SYMBOL: visited
: post-order-traversal ( bb -- )
- dup id>> visited get key? [ drop ] [
- dup id>> visited get conjoin
+ dup visited get key? [ drop ] [
+ dup visited get conjoin
[
successors>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
-: post-order ( bb -- blocks )
- [ post-order-traversal ] { } make ;
-
: number-blocks ( blocks -- )
- [ >>number drop ] each-index ;
+ dup length iota <reversed>
+ [ >>number drop ] 2each ;
+
+: post-order ( cfg -- blocks )
+ dup post-order>> [ ] [
+ [
+ H{ } clone visited set
+ dup entry>> post-order-traversal
+ ] { } make dup number-blocks
+ >>post-order post-order>>
+ ] ?if ;
-: reverse-post-order ( bb -- blocks )
- H{ } clone visited [
- post-order <reversed> dup number-blocks
- ] with-variable ; inline
+: reverse-post-order ( cfg -- blocks )
+ post-order <reversed> ; inline
: each-basic-block ( cfg quot -- )
- [ entry>> reverse-post-order ] dip each ; inline
-
-: change-basic-blocks ( cfg quot -- cfg' )
- [ '[ _ change-instructions drop ] each-basic-block ]
- [ drop ]
- 2bi ; inline
+ [ reverse-post-order ] dip each ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
+compiler.cfg.predecessors compiler.cfg.stack-analysis
+compiler.cfg.instructions sequences kernel tools.test accessors
+sequences.private alien math combinators.private compiler.cfg
+compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+sets ;
+IN: compiler.cfg.stack-analysis.tests
+
+! Fundamental invariant: a basic block should not load or store a value more than once
+: check-for-redundant-ops ( cfg -- )
+ [
+ instructions>>
+ [
+ [ ##peek? ] filter [ loc>> ] map duplicates empty?
+ [ "Redundant peeks" throw ] unless
+ ] [
+ [ ##replace? ] filter [ loc>> ] map duplicates empty?
+ [ "Redundant replaces" throw ] unless
+ ] bi
+ ] each-basic-block ;
+
+: test-stack-analysis ( quot -- cfg )
+ dup cfg? [ test-cfg first ] unless
+ compute-predecessors
+ delete-useless-blocks
+ delete-useless-conditionals
+ normalize-height
+ stack-analysis
+ dup check-cfg
+ dup check-for-redundant-ops ;
+
+: linearize ( cfg -- mr )
+ flatten-cfg instructions>> ;
+
+[ ] [ [ ] test-stack-analysis drop ] unit-test
+
+! Only peek once
+[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
+
+! Redundant replace is redundant
+[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+
+! Replace required here
+[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+
+! Only one replace, at the end
+[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
+
+! Do we support the full language?
+[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
+[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
+[ ] [
+ [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
+ test-cfg second test-stack-analysis drop
+] unit-test
+
+! Test loops
+[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
+[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
+
+! Make sure that peeks are inserted in the right place
+[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
+
+! This should be a total no-op
+[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+
+! Don't insert inc-d/inc-r; that's wrong!
+[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
+
+! Bug in height tracking
+[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
+[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
+[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
+
+! Bugs with code that throws
+[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
+[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
+[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
+[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
+
+! Make sure the replace stores a value with the right height
+[ ] [
+ [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
+ [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
+] unit-test
+
+! translate-loc was the wrong way round
+[ ] [
+ [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
+ [ [ ##load-immediate? ] count 2 assert= ]
+ [ [ ##peek? ] count 1 assert= ]
+ [ [ ##replace? ] count 3 assert= ]
+ tri
+] unit-test
+
+[ ] [
+ [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
+ [ [ ##load-immediate? ] count 2 assert= ]
+ [ [ ##peek? ] count 1 assert= ]
+ [ [ ##replace? ] count 1 assert= ]
+ tri
+] unit-test
+
+! Sync before a back-edge, not after
+! ##peeks should be inserted before a ##loop-entry
+! Don't optimize out the constants
+[ 1 t ] [
+ [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
+ [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces math sequences fry grouping
+sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.hats compiler.cfg ;
+IN: compiler.cfg.stack-analysis
+
+! Convert stack operations to register operations
+
+! If 'poisoned' is set, disregard height information. This is set if we don't have
+! height change information for an instruction.
+TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
+
+: <state> ( -- state )
+ state new
+ H{ } clone >>locs>vregs
+ H{ } clone >>actual-locs>vregs
+ H{ } clone >>changed-locs
+ 0 >>ds-height
+ 0 >>rs-height ;
+
+M: state clone
+ call-next-method
+ [ clone ] change-locs>vregs
+ [ clone ] change-actual-locs>vregs
+ [ clone ] change-changed-locs ;
+
+: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
+
+: record-peek ( dst loc -- )
+ state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
+
+: changed-loc ( loc -- )
+ state get changed-locs>> conjoin ;
+
+: record-replace ( src loc -- )
+ dup changed-loc state get locs>vregs>> set-at ;
+
+GENERIC: height-for ( loc -- n )
+
+M: ds-loc height-for drop state get ds-height>> ;
+M: rs-loc height-for drop state get rs-height>> ;
+
+: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
+M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
+
+GENERIC: untranslate-loc ( loc -- loc' )
+
+M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
+M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+
+: redundant-replace? ( vreg loc -- ? )
+ dup untranslate-loc n>> 0 <
+ [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
+
+: save-changed-locs ( state -- )
+ [ changed-locs>> ] [ locs>vregs>> ] bi '[
+ _ at swap 2dup redundant-replace?
+ [ 2drop ] [ untranslate-loc ##replace ] if
+ ] assoc-each ;
+
+: clear-state ( state -- )
+ [ locs>vregs>> clear-assoc ]
+ [ actual-locs>vregs>> clear-assoc ]
+ [ changed-locs>> clear-assoc ]
+ tri ;
+
+ERROR: poisoned-state state ;
+
+: sync-state ( -- )
+ state get {
+ [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+ [ save-changed-locs ]
+ [ clear-state ]
+ } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+ ##flushable
+ ##effect ;
+
+M: neutral-insn visit , ;
+
+UNION: sync-if-back-edge
+ ##branch
+ ##conditional-branch
+ ##compare-imm-branch
+ ##dispatch
+ ##loop-entry ;
+
+SYMBOL: local-only?
+
+t local-only? set-global
+
+: back-edge? ( from to -- ? )
+ [ number>> ] bi@ > ;
+
+: sync-state? ( -- ? )
+ basic-block get successors>>
+ [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
+ local-only? get or ;
+
+M: sync-if-back-edge visit
+ sync-state? [ sync-state ] when , ;
+
+: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
+
+M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
+
+: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
+
+M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
+
+: eliminate-peek ( dst src -- )
+ ! the requested stack location is already in 'src'
+ [ ##copy ] [ swap copies get set-at ] 2bi ;
+
+M: ##peek visit
+ dup
+ [ dst>> ] [ loc>> translate-loc ] bi
+ dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+
+M: ##replace visit
+ [ src>> resolve ] [ loc>> translate-loc ] bi
+ record-replace ;
+
+M: ##copy visit
+ [ call-next-method ] [ record-copy ] bi ;
+
+M: ##call visit
+ [ call-next-method ] [ height>> adjust-d ] bi ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+ ##jump
+ ##return
+ ##callback-return
+ ##fixnum-mul-tail
+ ##fixnum-add-tail
+ ##fixnum-sub-tail ;
+
+M: poison-insn visit call-next-method poison-state ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+ poison-insn
+ ##stack-frame
+ ##call
+ ##prologue
+ ##epilogue
+ ##fixnum-mul
+ ##fixnum-add
+ ##fixnum-sub
+ ##alien-invoke
+ ##alien-indirect ;
+
+M: kill-vreg-insn visit sync-state , ;
+
+: visit-alien-node ( node -- )
+ params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+M: ##alien-invoke visit
+ [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-indirect visit
+ [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-callback visit , ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
+
+ERROR: must-equal-failed seq ;
+
+: must-equal ( seq -- elt )
+ dup all-equal? [ first ] [ must-equal-failed ] if ;
+
+: merge-heights ( state predecessors states -- state )
+ nip
+ [ [ ds-height>> ] map must-equal >>ds-height ]
+ [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+
+: insert-peek ( predecessor loc -- vreg )
+ ! XXX critical edges
+ '[ _ ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors locs>vregs loc -- vreg )
+ ! Insert a ##phi in the current block where the input
+ ! is the vreg storing loc from each predecessor block
+ [ '[ [ _ ] dip at ] map ] keep
+ '[ [ ] [ _ insert-peek ] ?if ] 2map
+ dup all-equal? [ first ] [ ^^phi ] if ;
+
+: (merge-locs) ( predecessors assocs -- assoc )
+ dup [ keys ] map concat prune
+ [ [ 2nip ] [ merge-loc ] 3bi ] with with
+ H{ } map>assoc ;
+
+: merge-locs ( state predecessors states -- state )
+ [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+
+: merge-loc' ( locs>vregs loc -- vreg )
+ ! Insert a ##phi in the current block where the input
+ ! is the vreg storing loc from each predecessor block
+ '[ [ _ ] dip at ] map
+ dup all-equal? [ first ] [ drop f ] if ;
+
+: merge-actual-locs ( state predecessors states -- state )
+ nip
+ [ actual-locs>vregs>> ] map
+ dup [ keys ] map concat prune
+ [ [ nip ] [ merge-loc' ] 2bi ] with
+ H{ } map>assoc
+ [ nip ] assoc-filter
+ >>actual-locs>vregs ;
+
+: merge-changed-locs ( state predecessors states -- state )
+ nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+
+ERROR: cannot-merge-poisoned states ;
+
+: multiple-predecessors ( bb states -- state )
+ dup [ not ] any? [
+ [ <state> ] 2dip
+ sift merge-heights
+ ] [
+ dup [ poisoned?>> ] any? [
+ cannot-merge-poisoned
+ ] [
+ [ state new ] 2dip
+ [ predecessors>> ] dip
+ {
+ [ merge-locs ]
+ [ merge-actual-locs ]
+ [ merge-heights ]
+ [ merge-changed-locs ]
+ } 2cleave
+ ] if
+ ] if ;
+
+: merge-states ( bb states -- state )
+ ! If any states are poisoned, save all registers
+ ! to the stack in each branch
+ dup length {
+ { 0 [ initial-state ] }
+ { 1 [ single-predecessor ] }
+ [ drop multiple-predecessors ]
+ } case ;
+
+: block-in-state ( bb -- states )
+ dup predecessors>> state-out get '[ _ at ] map merge-states ;
+
+: set-block-in-state ( state bb -- )
+ [ clone ] dip state-in get set-at ;
+
+: set-block-out-state ( state bb -- )
+ [ clone ] dip state-out get set-at ;
+
+: visit-block ( bb -- )
+ ! block-in-state may add phi nodes at the start of the basic block
+ ! so we wrap the whole thing with a 'make'
+ [
+ dup basic-block set
+ dup block-in-state
+ [ swap set-block-in-state ] [
+ state [
+ [ instructions>> [ visit ] each ]
+ [ [ state get ] dip set-block-out-state ]
+ [ ]
+ tri
+ ] with-variable
+ ] 2bi
+ ] V{ } make >>instructions drop ;
+
+: stack-analysis ( cfg -- cfg' )
+ [
+ H{ } clone copies set
+ H{ } clone state-in set
+ H{ } clone state-out set
+ dup [ visit-block ] each-basic-block
+ ] with-scope ;
frame-required? on
] when ;
-\ _gc t frame-required? set-word-prop
\ _spill t frame-required? set-word-prop
+\ ##gc t frame-required? set-word-prop
\ ##fixnum-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences compiler.utilities
-compiler.cfg.instructions cpu.architecture ;
+USING: accessors arrays kernel sequences make compiler.cfg.instructions
+compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! has a LEA instruction which is effectively a three-operand
! addition
-: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
-: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
-: convert-two-operand/integer ( insn -- insns )
- [ [ dst>> ] [ src1>> ] bi make-copy ]
- [ dup dst>> >>src1 ]
- bi 2array ; inline
+: convert-two-operand/integer ( insn -- )
+ [ [ dst>> ] [ src1>> ] bi ##copy ]
+ [ dup dst>> >>src1 , ]
+ bi ; inline
-: convert-two-operand/float ( insn -- insns )
- [ [ dst>> ] [ src1>> ] bi make-copy/float ]
- [ dup dst>> >>src1 ]
- bi 2array ; inline
+: convert-two-operand/float ( insn -- )
+ [ [ dst>> ] [ src1>> ] bi ##copy-float ]
+ [ dup dst>> >>src1 , ]
+ bi ; inline
-GENERIC: convert-two-operand* ( insn -- insns )
+GENERIC: convert-two-operand* ( insn -- )
M: ##not convert-two-operand*
- [ [ dst>> ] [ src>> ] bi make-copy ]
- [ dup dst>> >>src ]
- bi 2array ;
+ [ [ dst>> ] [ src>> ] bi ##copy ]
+ [ dup dst>> >>src , ]
+ bi ;
M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;
M: ##div-float convert-two-operand* convert-two-operand/float ;
-M: insn convert-two-operand* ;
+M: insn convert-two-operand* , ;
-: convert-two-operand ( mr -- mr' )
- [
- two-operand? [
- [ convert-two-operand* ] map-flat
- ] when
- ] change-instructions ;
+: convert-two-operand ( cfg -- cfg' )
+ two-operand? [
+ dup [
+ [
+ [ [ convert-two-operand* ] each ] V{ } make
+ ] change-instructions drop
+ ] each-basic-block
+ ] when ;
--- /dev/null
+IN: compiler.cfg.useless-blocks.tests
+USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
+
+{
+ [ [ drop 1 ] when ]
+ [ [ drop 1 ] unless ]
+} [
+ [ [ ] ] dip
+ '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
+] each
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators classes vectors
-compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+USING: kernel accessors sequences combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.useless-blocks
: update-predecessor-for-delete ( bb -- )
+ ! We have to replace occurrences of bb with bb's successor
+ ! in bb's predecessor's list of successors.
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] change-successors drop ;
: update-successor-for-delete ( bb -- )
- [ predecessors>> first ]
- [ successors>> first predecessors>> ]
- bi set-first ;
+ ! We have to replace occurrences of bb with bb's predecessor
+ ! in bb's sucessor's list of predecessors.
+ dup successors>> first [
+ [
+ 2dup eq? [ drop predecessors>> first ] [ nip ] if
+ ] with map
+ ] change-predecessors drop ;
: delete-basic-block ( bb -- )
[ update-predecessor-for-delete ]
: delete-basic-block? ( bb -- ? )
{
- { [ dup instructions>> length 1 = not ] [ f ] }
- { [ dup predecessors>> length 1 = not ] [ f ] }
- { [ dup successors>> length 1 = not ] [ f ] }
- { [ dup instructions>> first ##branch? not ] [ f ] }
- [ t ]
- } cond nip ;
+ [ instructions>> length 1 = ]
+ [ predecessors>> length 1 = ]
+ [ successors>> length 1 = ]
+ [ instructions>> first ##branch? ]
+ } 1&& ;
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
- ] each-basic-block ;
+ ] each-basic-block
+ f >>post-order ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
- [ but-last f \ ##branch boa suffix ] change-instructions
+ [ but-last \ ##branch new-insn suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
- ] each-basic-block ;
+ ] each-basic-block
+ f >>post-order ;
: stop-iterating ( -- next ) end-basic-block f ;
+: call-height ( ##call -- n )
+ [ out-d>> length ] [ in-d>> length ] bi - ;
+
: emit-primitive ( node -- )
- word>> ##call ##branch begin-basic-block ;
+ [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
and
] [ 2drop f ] if ;
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
- input-expr-counter [ dup 1 + ] change ;
-
! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
TUPLE: input-expr < expr n ;
+SYMBOL: input-expr-counter
+
+: next-input-expr ( class -- expr )
+ input-expr-counter [ dup 1 + ] change input-expr boa ;
+
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )
M: ##compare-float >expr compare>expr ;
-M: ##flushable >expr class next-input-expr input-expr boa ;
+M: ##flushable >expr class next-input-expr ;
: init-expressions ( -- )
0 input-expr-counter set ;
M: ##mul-imm rewrite
dup src2>> dup power-of-2? [
- [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+ [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
dup number-values
] [ drop ] if ;
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
- { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
- { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
- { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+ { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
+ { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+ { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
} case ;
: tag-fixnum-expr? ( expr -- ? )
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison
- (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+ (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
- i f \ ##compare-imm boa ;
+ i \ ##compare-imm new-insn ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
- cc= f i \ ##compare-imm boa ;
+ cc= i \ ##compare-imm new-insn ;
M: ##compare rewrite
dup flip-comparison? [
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
- { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
- { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
+ { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
+ { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
+ { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
] when
] when ;
-: dispatch-offset ( expr -- n )
- [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
- \ ##sub-imm eq? [ neg ] when ;
-
-: add-dispatch-offset? ( insn -- expr ? )
- src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
-
-M: ##dispatch rewrite
- dup add-dispatch-offset? [
- [ clone ] dip
- [ in1>> vn>vreg >>src ]
- [ dispatch-offset '[ _ + ] change-offset ] bi
- ] [ drop ] if ;
-
M: insn rewrite ;
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
tools.test kernel math combinators.short-circuit accessors
-sequences ;
+sequences compiler.cfg vectors arrays ;
: trim-temps ( insns -- insns )
[
} 1|| [ f >>temp ] when
] map ;
+: test-value-numbering ( insns -- insns )
+ { } init-value-numbering
+ value-numbering-step ;
+
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
- } value-numbering
+ } test-value-numbering
] unit-test
[
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
- } value-numbering
+ } test-value-numbering
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
- T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
- } dup value-numbering =
+ T{ ##dispatch f V int-regs 1 V int-regs 2 }
+ } dup test-value-numbering =
] unit-test
[ t ] [
T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
T{ ##replace f V int-regs 23 D 0 }
- } dup value-numbering =
+ } dup test-value-numbering =
] unit-test
[
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 3 D 0 }
- } value-numbering
+ } test-value-numbering
] unit-test
[
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
- } value-numbering trim-temps
+ } test-value-numbering trim-temps
] unit-test
[
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
- } value-numbering trim-temps
+ } test-value-numbering trim-temps
] unit-test
[
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
- } value-numbering trim-temps
+ } test-value-numbering trim-temps
] unit-test
[
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
- } value-numbering trim-temps
+ } test-value-numbering trim-temps
+] unit-test
+
+[
+ {
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+ }
+] [
+ { V int-regs 45 } init-value-numbering
+ {
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+ } value-numbering-step
] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences
+compiler.cfg.local
+compiler.cfg.liveness
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
-: value-numbering ( insns -- insns' )
+: number-input-values ( live-in -- )
+ [ [ f next-input-expr simplify ] dip set-vn ] each ;
+
+: init-value-numbering ( live-in -- )
init-value-graph
init-expressions
+ number-input-values ;
+
+: value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite propagate ] bi ] map ;
+
+: value-numbering ( cfg -- cfg' )
+ [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test ;
+arrays tools.test vectors compiler.cfg kernel accessors ;
IN: compiler.cfg.write-barrier.tests
+: test-write-barrier ( insns -- insns )
+ write-barriers-step ;
+
[
{
T{ ##peek f V int-regs 4 D 0 f }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
- } eliminate-write-barriers
+ } test-write-barrier
] unit-test
[
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
- } eliminate-write-barriers
+ } test-write-barrier
] unit-test
[
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
- } eliminate-write-barriers
+ } test-write-barrier
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
-compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg.liveness compiler.cfg.local ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
M: insn eliminate-write-barrier ;
-: eliminate-write-barriers ( insns -- insns' )
+: write-barriers-step ( insns -- insns' )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
+
+: eliminate-write-barriers ( cfg -- cfg' )
+ [ drop ] [ write-barriers-step ] local-optimization ;
--- /dev/null
+IN: compiler.codegen.tests
+USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
+compiler.constants ;
+
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
-: generate-insns ( insns -- code )
- [
- [
- dup regs>> registers set
- generate-insn
- ] each
- ] { } make fixup ;
-
TUPLE: asm label code calls ;
SYMBOL: calls
: init-generator ( word -- )
H{ } clone labels set
- V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? [ compiling-word get add-literal ] when ;
-: generate ( mr -- asm )
+: generate-insns ( asm -- code )
[
- [ label>> ]
[ word>> init-generator ]
- [ instructions>> generate-insns ] tri
- calls get
+ [
+ instructions>>
+ [ [ regs>> registers set ] [ generate-insn ] bi ] each
+ ] bi
+ ] with-fixup ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ] [ generate-insns ] bi calls get
asm boa
] with-scope ;
M: ##return generate-insn drop %return ;
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
+M: _dispatch generate-insn
+ [ src>> register ] [ temp>> register ] bi %dispatch ;
-M: ##dispatch generate-insn
- [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+M: _dispatch-label generate-insn
+ label>> lookup-label %dispatch-label ;
: >slot< ( insn -- dst obj slot tag )
{
[ table>> register ]
tri %write-barrier ;
-M: _gc generate-insn drop %gc ;
+M: ##gc generate-insn drop %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
- id>> lookup-label , ;
+ id>> lookup-label resolve-label ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
IN: compiler.codegen.fixup
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
-: compiled-offset ( -- n ) building get length ;
+: add-literal ( obj -- ) literal-table get push ;
-SYMBOL: relocation-table
+! Labels
SYMBOL: label-table
-M: label fixup* compiled-offset >>offset drop ;
+TUPLE: label offset ;
-TUPLE: label-fixup label class ;
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
-: label-fixup ( label class -- ) \ label-fixup boa , ;
+: compiled-offset ( -- n ) building get length ;
-M: label-fixup fixup*
- dup class>> rc-absolute?
- [ "Absolute labels not supported" throw ] when
- [ class>> ] [ label>> ] bi compiled-offset 4 - swap
- 3array label-table get push ;
+: resolve-label ( label/name -- )
+ dup label? [ get ] unless
+ compiled-offset >>offset drop ;
-TUPLE: rel-fixup class type ;
+: offset-for-class ( class -- n )
+ rc-absolute-cell = cell 4 ? compiled-offset swap - ;
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+ dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
+SYMBOL: relocation-table
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
-M: rel-fixup fixup*
- [ type>> ]
- [ class>> ]
- [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
- { 0 24 28 } bitfield
- relocation-table get push-4 ;
-
-M: integer fixup* , ;
+: add-relocation-entry ( type class offset -- )
+ { 0 24 28 } bitfield relocation-table get push-4 ;
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+ swap dup offset-for-class add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-here ( offset class -- )
[ add-literal ] dip rt-here rel-fixup ;
-: init-fixup ( -- )
- BV{ } clone relocation-table set
- V{ } clone label-table set ;
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+ label>> offset>> [ "Unresolved label" throw ] unless* ;
-: resolve-labels ( labels -- labels' )
- [
- first3 offset>>
- [ "Unresolved label" throw ] unless*
- 3array
- ] map concat ;
+: resolve-absolute-label ( label-fixup -- )
+ dup resolve-offset neg add-literal
+ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- label )
+ [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+ [ class>> rc-absolute? ] partition
+ [ [ resolve-absolute-label ] each ]
+ [ [ resolve-relative-label ] map concat ]
+ bi* ;
+
+: init-fixup ( -- )
+ V{ } clone literal-table set
+ V{ } clone label-table set
+ BV{ } clone relocation-table set ;
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
[
init-fixup
- [ fixup* ] each
+ call
+ label-table [ resolve-labels ] change
literal-table get >array
relocation-table get >byte-array
- label-table get resolve-labels
- ] B{ } make 4array ;
+ label-table get
+ ] B{ } make 4array ; inline
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
-source-files.errors stack-checker stack-checker.state
-stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
-compiler.utilities ;
+source-files.errors combinators.short-circuit
+
+stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+
+compiler.errors compiler.units compiler.utilities
+
+compiler.tree.builder
+compiler.tree.optimizer
+
+compiler.cfg.builder
+compiler.cfg.optimizer
+compiler.cfg.mr
+
+compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
: not-compiled-def ( word error -- def )
'[ _ _ not-compiled ] [ ] like ;
+: deoptimize* ( word -- * )
+ dup def>> deoptimize-with ;
+
: ignore-error ( word error -- * )
- drop
- [ clear-compiler-error ]
- [ dup def>> deoptimize-with ]
- bi ;
+ drop [ clear-compiler-error ] [ deoptimize* ] bi ;
: remember-error ( word error -- * )
[ swap <compiler-error> compiler-error ]
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
-: frontend ( word -- nodes )
+: frontend ( word -- tree )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
- contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
- ] [ dup def>> deoptimize-with ] if ;
+ contains-breakpoints? [ nip deoptimize* ] [ drop ] if
+ ] [ deoptimize* ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
[ compile-dependencies ]
bi ;
-: backend ( nodes word -- )
+: backend ( tree word -- )
build-cfg [
optimize-cfg
build-mr
- convert-two-operand
- linear-scan
- build-stack-frame
generate
save-asm
] each ;
] when ;
: optimize-tree ( nodes -- nodes' )
- analyze-recursive
- normalize
- propagate
- cleanup
- dup run-escape-analysis? [
- escape-analysis
- unbox-tuples
- ] when
- apply-identities
- compute-def-use
- remove-dead-code
- ?check
- compute-def-use
- optimize-modular-arithmetic
- finalize ;
+ [
+ analyze-recursive
+ normalize
+ propagate
+ cleanup
+ dup run-escape-analysis? [
+ escape-analysis
+ unbox-tuples
+ ] when
+ apply-identities
+ compute-def-use
+ remove-dead-code
+ ?check
+ compute-def-use
+ optimize-modular-arithmetic
+ finalize
+ ] with-scope ;
[ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
- <threaded-server>
+ binary <threaded-server>
swap >>insecure
- binary >>encoding
"concurrency.distributed" >>name
[ handle-node-client ] >>handler ;
classes alien byte-arrays combinators words sets fry ;
IN: cpu.architecture
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
-HOOK: %dispatch cpu ( src temp offset -- )
-HOOK: %dispatch-label cpu ( word -- )
+HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( label -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )
HOOK: %slot-imm cpu ( dst obj slot tag -- )
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
-M:: ppc %dispatch ( src temp offset -- )
+M:: ppc %dispatch ( src temp -- )
0 temp LOAD32
- 4 offset + cells rc-absolute-ppc-2/2 rel-here
+ 4 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;
-M: ppc %dispatch-label ( word -- )
- B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
-
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
temp tag neg ; inline
M: x86.32 temp-reg-1 ECX ;
M: x86.32 temp-reg-2 EDX ;
-M:: x86.32 %dispatch ( src temp offset -- )
+M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
src HEX: ffffffff ADD
- offset cells rc-absolute-cell rel-here
+ 0 rc-absolute-cell rel-here
! Go
src HEX: 7f [+] JMP
! Fix up the displacement above
4 "double" c-type (>>align)
] unless
-FUNCTION: bool check_sse2 ( ) ;
-
-: sse2? ( -- ? )
- check_sse2 ;
+USING: cpu.x86.features cpu.x86.features.private ;
"-no-sse2" (command-line) member? [
[ { check_sse2 } compile ] with-optimizer
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M:: x86.64 %dispatch ( src temp offset -- )
+M:: x86.64 %dispatch ( src temp -- )
! Load jump table base.
temp HEX: ffffffff MOV
- offset cells rc-absolute-cell rel-here
+ 0 rc-absolute-cell rel-here
! Add jump table base
src temp ADD
src HEX: 7f [+] JMP
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: cpu.x86.features.tests
+USING: cpu.x86.features tools.test kernel sequences math system ;
+
+cpu x86? [
+ [ t ] [ sse2? { t f } member? ] unit-test
+ [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
+] when
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel math alien.syntax ;
+IN: cpu.x86.features
+
+<PRIVATE
+
+FUNCTION: bool check_sse2 ( ) ;
+
+FUNCTION: longlong read_timestamp_counter ( ) ;
+
+PRIVATE>
+
+HOOK: sse2? cpu ( -- ? )
+
+M: x86.32 sse2? check_sse2 ;
+
+M: x86.64 sse2? t ;
+
+HOOK: instruction-count cpu ( -- n )
+
+M: x86 instruction-count read_timestamp_counter ;
+
+: count-instructions ( quot -- n )
+ instruction-count [ call ] dip instruction-count swap - ; inline
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )
- [ building get [ integer? ] count dup ] dip align swap - ;
+ [ building get length dup ] dip align swap - ;
: align-code ( n -- )
0 <repetition> % ;
-M: x86 %dispatch-label ( word -- )
- 0 cell, rc-absolute-cell rel-word ;
+M: x86 %dispatch-label ( label -- )
+ 0 cell, rc-absolute-cell label-fixup ;
:: (%slot) ( obj slot tag temp -- op )
temp slot obj [+] LEA
] with-destructors ;
: <ftp-server> ( directory port -- server )
- ftp-server new-threaded-server
+ latin1 ftp-server new-threaded-server
swap >>insecure
swap canonicalize-path >>serving-directory
"ftp.server" >>name
- 5 minutes >>timeout
- latin1 >>encoding ;
+ 5 minutes >>timeout ;
: ftpd ( directory port -- )
<ftp-server> start-server ;
] with-destructors ;
: <http-server> ( -- server )
- http-server new-threaded-server
+ ascii http-server new-threaded-server
"http.server" >>name
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
HELP: new-threaded-server
-{ $values { "class" class } { "threaded-server" threaded-server } }
+{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
HELP: <threaded-server>
-{ $values { "threaded-server" threaded-server } }
-{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
+{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
+{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
HELP: remote-address
{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
io.servers.connection.private kernel accessors sequences
concurrency.promises io.encodings.ascii io threads calendar ;
-[ t ] [ <threaded-server> listen-on empty? ] unit-test
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
[ f ] [
- <threaded-server>
+ ascii <threaded-server>
25 internet-server >>insecure
listen-on
empty?
and
] unit-test
-[ ] [ <threaded-server> init-server drop ] unit-test
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
[ 10 ] [
- <threaded-server>
+ ascii <threaded-server>
10 >>max-connections
init-server semaphore>> count>>
] unit-test
[ ] [
- <threaded-server>
+ ascii <threaded-server>
5 >>max-connections
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
: internet-server ( port -- addrspec ) f swap <inet> ;
-: new-threaded-server ( class -- threaded-server )
+: new-threaded-server ( encoding class -- threaded-server )
new
+ swap >>encoding
"server" >>name
DEBUG >>log-level
- ascii >>encoding
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
[ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline
-: <threaded-server> ( -- threaded-server )
+: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
GENERIC: handle-client* ( threaded-server -- )
[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
+[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test
\ No newline at end of file
M: ratio ^n
[ >fraction ] dip [ ^n ] curry bi@ / ;
-M: float ^n
- (^n) ;
+M: float ^n (^n) ;
+
+M: complex ^n (^n) ;
: integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
CYGWIN_NT-5.2-WOW64) OS=winnt;;
*CYGWIN_NT*) OS=winnt;;
*CYGWIN*) OS=winnt;;
+ MINGW32*) OS=winnt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
[ 1 f ] [ 1 H{ } ?at ] unit-test
[ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test
+
+[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
+[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
+[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
: ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline
+: maybe-set-at ( value key assoc -- changed? )
+ 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
+
<PRIVATE
: (assoc-each) ( assoc quot -- seq quot' )
: save-class-location ( class -- )
location remember-class ;
-: create-class-in ( word -- word )
+: create-class-in ( string -- word )
current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cursors math tools.test make ;
+IN: cursors.tests
+
+[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
+[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
+[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
+
+[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
+[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
+[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
+[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
+
+[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math sequences sequences.private ;
+IN: cursors
+
+GENERIC: cursor-done? ( cursor -- ? )
+GENERIC: cursor-get-unsafe ( cursor -- obj )
+GENERIC: cursor-advance ( cursor -- )
+GENERIC: cursor-valid? ( cursor -- ? )
+GENERIC: cursor-write ( obj cursor -- )
+
+ERROR: cursor-ended cursor ;
+
+: cursor-get ( cursor -- obj )
+ dup cursor-done?
+ [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+
+: find-done? ( cursor quot -- ? )
+ over cursor-done?
+ [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
+
+: cursor-until ( cursor quot -- )
+ [ find-done? not ]
+ [ drop cursor-advance ] bi-curry bi-curry while ; inline
+
+: cursor-each ( cursor quot -- )
+ [ f ] compose cursor-until ; inline
+
+: cursor-find ( cursor quot -- obj ? )
+ [ cursor-until ] [ drop ] 2bi
+ dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+
+: cursor-any? ( cursor quot -- ? )
+ cursor-find nip ; inline
+
+: cursor-all? ( cursor quot -- ? )
+ [ not ] compose cursor-any? not ; inline
+
+: cursor-map-quot ( quot to -- quot' )
+ [ [ call ] dip cursor-write ] 2curry ; inline
+
+: cursor-map ( from to quot -- )
+ swap cursor-map-quot cursor-each ; inline
+
+: cursor-write-if ( obj quot to -- )
+ [ over [ call ] dip ] dip
+ [ cursor-write ] 2curry when ; inline
+
+: cursor-filter-quot ( quot to -- quot' )
+ [ cursor-write-if ] 2curry ; inline
+
+: cursor-filter ( from to quot -- )
+ swap cursor-filter-quot cursor-each ; inline
+
+TUPLE: from-sequence { seq sequence } { n integer } ;
+
+: >from-sequence< ( from-sequence -- n seq )
+ [ n>> ] [ seq>> ] bi ; inline
+
+M: from-sequence cursor-done? ( cursor -- ? )
+ >from-sequence< length >= ;
+
+M: from-sequence cursor-valid?
+ >from-sequence< bounds-check? not ;
+
+M: from-sequence cursor-get-unsafe
+ >from-sequence< nth-unsafe ;
+
+M: from-sequence cursor-advance
+ [ 1+ ] change-n drop ;
+
+: >input ( seq -- cursor )
+ 0 from-sequence boa ; inline
+
+: iterate ( seq quot iterator -- )
+ [ >input ] 2dip call ; inline
+
+: each ( seq quot -- ) [ cursor-each ] iterate ; inline
+: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
+: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
+: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
+
+TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
+
+M: to-sequence cursor-write
+ seq>> push ;
+
+: freeze ( cursor -- seq )
+ [ seq>> ] [ exemplar>> ] bi like ; inline
+
+: >output ( seq -- cursor )
+ [ [ length ] keep new-resizable ] keep
+ to-sequence boa ; inline
+
+: transform ( seq quot transformer -- newseq )
+ [ [ >input ] [ >output ] bi ] 2dip
+ [ call ]
+ [ 2drop freeze ] 3bi ; inline
+
+: map ( seq quot -- ) [ cursor-map ] transform ; inline
+: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
: server ( port -- server )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ start-listener ] >>handler
f >>timeout ;
dup dup >vocab-link where normalize-loc 4array ;
: sort-xrefs ( seq -- seq' )
- [ [ first ] dip first <=> ] sort ; inline
+ [ [ first ] dip first <=> ] sort ;
: format-xrefs ( seq -- seq' )
- [ word? ] filter [ word>xref ] map ; inline
+ [ word? ] filter [ word>xref ] map ;
: filter-prefix ( seq prefix -- seq )
- [ drop-prefix nip length 0 = ] curry filter prune ; inline
+ [ drop-prefix nip length 0 = ] curry filter prune ;
MEMO: (vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
: current-words ( -- seq )
manifest get
[ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
- assoc-union keys ; inline
+ assoc-union keys ;
: vocabs-words ( names -- seq )
- prune [ (vocab-words) ] map concat ; inline
+ prune [ (vocab-words) ] map concat ;
PRIVATE>
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.smart
+destructors fry io io.encodings.utf8 kernel managed-server
+namespaces parser sequences sorting splitting strings.parser
+unicode.case unicode.categories calendar calendar.format
+locals multiline io.encodings.binary io.encodings.string
+prettyprint ;
+IN: managed-server.chat
+
+TUPLE: chat-server < managed-server ;
+
+SYMBOL: commands
+commands [ H{ } clone ] initialize
+
+SYMBOL: chat-docs
+chat-docs [ H{ } clone ] initialize
+
+CONSTANT: line-beginning "-!- "
+
+: send-line ( string -- )
+ write "\r\n" write flush ;
+
+: handle-me ( string -- )
+ [
+ [ "* " username " " ] dip
+ ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+ client [ (>>object) ] [ t >>quit? drop ] bi ;
+
+: handle-help ( string -- )
+ [
+ "Commands: "
+ commands get keys natural-sort ", " join append send-line
+ ] [
+ chat-docs get ?at
+ [ send-line ]
+ [ "Unknown command: " prepend send-line ] if
+ ] if-empty ;
+
+: usage ( string -- )
+ chat-docs get at send-line ;
+
+: username-taken-string ( username -- string )
+ "The username ``" "'' is already in use; try again." surround ;
+
+: warn-name-changed ( old new -- )
+ [
+ [ line-beginning "``" ] 2dip
+ [ "'' is now known as ``" ] dip "''"
+ ] "" append-outputs-as send-everyone ;
+
+: handle-nick ( string -- )
+ [
+ "nick" usage
+ ] [
+ dup clients key? [
+ username-taken-string send-line
+ ] [
+ [ username swap warn-name-changed ]
+ [ username clients rename-at ]
+ [ client (>>username) ] tri
+ ] if
+ ] if-empty ;
+
+:: add-command ( quot docs key -- )
+ quot key commands get set-at
+ docs key chat-docs get set-at ;
+
+[ handle-help ]
+<" Syntax: /help [command]
+Displays the documentation for a command.">
+"help" add-command
+
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
+<" Syntax: /who
+Shows the list of connected users.">
+"who" add-command
+
+[ drop gmt timestamp>rfc822 send-line ]
+<" Syntax: /time
+Returns the current GMT time."> "time" add-command
+
+[ handle-nick ]
+<" Syntax: /nick nickname
+Changes your nickname.">
+"nick" add-command
+
+[ handle-me ]
+<" Syntax: /me action">
+"me" add-command
+
+[ handle-quit ]
+<" Syntax: /quit [message]
+Disconnects a user from the chat server."> "quit" add-command
+
+: handle-command ( string -- )
+ dup " " split1 swap >lower commands get at* [
+ call( string -- ) drop
+ ] [
+ 2drop "Unknown command: " prepend send-line
+ ] if ;
+
+: <chat-server> ( port -- managed-server )
+ "chat-server" utf8 chat-server new-managed-server ;
+
+: handle-chat ( string -- )
+ [
+ [ username ": " ] dip
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-login
+ "Username: " write flush
+ readln ;
+
+M: chat-server handle-client-join
+ [
+ line-beginning username " has joined"
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-disconnect
+ [
+ line-beginning username " has quit "
+ client object>> dup [ "\"" dup surround ] when
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-already-logged-in
+ username username-taken-string send-line ;
+
+M: chat-server handle-managed-client*
+ readln dup f = [ t client (>>quit?) ] when
+ [
+ "/" ?head [ handle-command ] [ handle-chat ] if
+ ] unless-empty ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar continuations destructors io
+io.encodings.binary io.servers.connection io.sockets
+io.streams.duplex fry kernel locals math math.ranges multiline
+namespaces prettyprint random sequences sets splitting threads
+tools.continuations ;
+IN: managed-server
+
+TUPLE: managed-server < threaded-server clients ;
+
+TUPLE: managed-client
+input-stream output-stream local-address remote-address
+username object quit? ;
+
+HOOK: handle-login threaded-server ( -- username )
+HOOK: handle-managed-client* managed-server ( -- )
+HOOK: handle-already-logged-in managed-server ( -- )
+HOOK: handle-client-join managed-server ( -- )
+HOOK: handle-client-disconnect managed-server ( -- )
+
+ERROR: already-logged-in username ;
+
+M: managed-server handle-already-logged-in already-logged-in ;
+M: managed-server handle-client-join ;
+M: managed-server handle-client-disconnect ;
+
+: server ( -- managed-client ) managed-server get ;
+: client ( -- managed-client ) managed-client get ;
+: clients ( -- assoc ) server clients>> ;
+: client-streams ( -- assoc ) clients values ;
+: username ( -- string ) client username>> ;
+: everyone-else ( -- assoc )
+ clients [ drop username = not ] assoc-filter ;
+: everyone-else-streams ( -- assoc ) everyone-else values ;
+
+ERROR: no-such-client username ;
+
+<PRIVATE
+
+: (send-client) ( managed-client seq -- )
+ [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
+
+PRIVATE>
+
+: send-client ( seq username -- )
+ clients ?at [ no-such-client ] [ (send-client) ] if ;
+
+: send-everyone ( seq -- )
+ [ client-streams ] dip '[ _ (send-client) ] each ;
+
+: send-everyone-else ( seq -- )
+ [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
+
+<PRIVATE
+
+: <managed-client> ( username -- managed-client )
+ managed-client new
+ swap >>username
+ input-stream get >>input-stream
+ output-stream get >>output-stream
+ local-address get >>local-address
+ remote-address get >>remote-address ;
+
+: check-logged-in ( username -- username )
+ dup clients key? [ handle-already-logged-in ] when ;
+
+: add-managed-client ( -- )
+ client username check-logged-in clients set-at ;
+
+: delete-managed-client ( -- )
+ username server clients>> delete-at ;
+
+: handle-managed-client ( -- )
+ handle-login <managed-client> managed-client set
+ add-managed-client handle-client-join
+ [ handle-managed-client* client quit?>> not ] loop ;
+
+PRIVATE>
+
+M: managed-server handle-client*
+ managed-server set
+ [ handle-managed-client ]
+ [ delete-managed-client handle-client-disconnect ]
+ [ ] cleanup ;
+
+: new-managed-server ( port name encoding class -- server )
+ new-threaded-server
+ swap >>name
+ swap >>insecure
+ f >>timeout
+ H{ } clone >>clients ; inline
: start-mmm-server ( -- )
output-stream get mmm-dump-output set
- <threaded-server> [ mmm-t-srv set ] keep
+ binary <threaded-server> [ mmm-t-srv set ] keep
"127.0.0.1" mmm-port get <inet4> >>insecure
- binary >>encoding
[ handle-mmm-connection ] >>handler
start-server* ;
check-options
start-mmm-server ;
-MAIN: run-mmm
\ No newline at end of file
+MAIN: run-mmm
! unit circle as NURBS
3 {
{ 1.0 0.0 1.0 }
- { $ √2/2 $ √2/2 $ √2/2 }
+ ${ √2/2 √2/2 √2/2 }
{ 0.0 1.0 1.0 }
- { $ -√2/2 $ √2/2 $ √2/2 }
+ ${ -√2/2 √2/2 √2/2 }
{ -1.0 0.0 1.0 }
- { $ -√2/2 $ -√2/2 $ √2/2 }
+ ${ -√2/2 -√2/2 √2/2 }
{ 0.0 -1.0 1.0 }
- { $ √2/2 $ -√2/2 $ √2/2 }
+ ${ √2/2 -√2/2 √2/2 }
{ 1.0 0.0 1.0 }
} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences sequences.product ;
-IN: sequences
+USING: help.markup help.syntax multiline quotations sequences ;
+IN: sequences.product
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.servers.connection accessors threads
-calendar calendar.format ;
+USING: accessors calendar calendar.format io io.encodings.ascii
+io.servers.connection threads ;
IN: time-server
: handle-time-client ( -- )
now timestamp>rfc822 print ;
: <time-server> ( -- threaded-server )
- <threaded-server>
+ ascii <threaded-server>
"time-server" >>name
1234 >>insecure
[ handle-time-client ] >>handler ;
IN: tty-server
: <tty-server> ( port -- )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ listener ] >>handler
start-server ;
io.encodings.binary io.servers.connection kernel
memoize namespaces parser sets sequences serialize
threads vocabs vocabs.parser words ;
-
IN: modules.rpc-server
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
+ [ execute ] curry with-datastack object>bytes ; inline
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- ) [
- <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
- start-server ] in-thread ;
-
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
+: process ( vocabspec -- )
+ vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- )
+ deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- )
+ [
+ binary <threaded-server>
+ 5000 >>insecure
+ [ (serve) ] >>handler
+ start-server
+ ] in-thread ;
+
+: (service) ( -- )
+ serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
SYNTAX: service \ do-rpc "executer" set (service) ;
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
load-vocab-hook [
- [ dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
-append ] change-global
\ No newline at end of file
+ [
+ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
+ ] append
+] change-global
case RT_XT_PIC_TAIL:
return (cell)word_xt_pic_tail(untag<word>(ARG));
case RT_HERE:
- return offset + (short)untag_fixnum(ARG);
+ {
+ fixnum arg = untag_fixnum(ARG);
+ return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+ }
case RT_THIS:
return (cell)(compiled + 1);
case RT_STACK_CHAIN:
mov %edx,%eax
ret
+DEF(long long,read_timestamp_counter,(void)):
+ rdtsc
+ ret
+
DEF(void,primitive_inline_cache_miss,(void)):
mov (%esp),%ebx
DEF(void,primitive_inline_cache_miss_tail,(void)):
#ifdef WINDOWS
.section .drectve
.ascii " -export:check_sse2"
+ .ascii " -export:read_timestamp_counter"
#endif
call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
+DEF(long long,read_timestamp_counter,(void)):
+ mov $0,%rax
+ rdtsc
+ shl $32,%rdx
+ or %rdx,%rax
+ ret
+
DEF(void,primitive_inline_cache_miss,(void)):
mov (%rsp),%rbx
DEF(void,primitive_inline_cache_miss_tail,(void)):
projects / factor.git / commitdiff