--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces make math sequences layouts
+alien.c-types alien.structs cpu.architecture ;
+IN: compiler.alien
+
+: large-struct? ( ctype -- ? )
+ dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+ dup parameters>>
+ swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+ return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+ dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+ over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+ #! Compute stack frame locations.
+ [
+ 0 [
+ [ parameter-align drop dup , ] keep stack-size +
+ ] reduce cell align
+ ] { } make ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.cfg.builder.tests
+USING: tools.test kernel sequences
+words sequences.private fry prettyprint alien
+math.private compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger ;
+
+! Just ensure that various CFGs build correctly.
+{
+ [ ]
+ [ dup ]
+ [ swap ]
+ [ >r r> ]
+ [ fixnum+ ]
+ [ fixnum< ]
+ [ [ 1 ] [ 2 ] if ]
+ [ fixnum< [ 1 ] [ 2 ] if ]
+ [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
+ [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
+ [ [ t ] loop ]
+ [ [ dup ] loop ]
+ [ [ 2 ] [ 3 throw ] if 4 ]
+ [ "int" f "malloc" { "int" } alien-invoke ]
+ [ "int" { "int" } "cdecl" alien-indirect ]
+ [ "int" { "int" } "cdecl" [ ] alien-callback ]
+} [
+ '[ _ test-cfg drop ] [ ] swap unit-test
+] each
+
+: test-1 ( -- ) test-1 ;
+: test-2 ( -- ) 3 . test-2 ;
+: test-3 ( a -- b ) dup [ test-3 ] when ;
+
+{
+ test-1
+ test-2
+ test-3
+} [
+ '[ _ test-cfg drop ] [ ] swap unit-test
+] each
--- /dev/null
+ ! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators hashtables kernel
+math fry namespaces make sequences words byte-arrays
+locals layouts alien.c-types alien.structs
+stack-checker.inlining
+compiler.intrinsics
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.cfg.stacks
+compiler.cfg.templates
+compiler.cfg.iterator
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.alien ;
+IN: compiler.cfg.builder
+
+! Convert tree SSA IR to CFG (not quite SSA yet) IR.
+
+: set-basic-block ( basic-block -- )
+ [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+ <basic-block> basic-block get [
+ dupd successors>> push
+ ] when*
+ set-basic-block ;
+
+: end-basic-block ( -- )
+ building off
+ basic-block off ;
+
+: stop-iterating ( -- next ) end-basic-block f ;
+
+SYMBOL: procedures
+SYMBOL: current-word
+SYMBOL: current-label
+SYMBOL: loops
+
+! Basic block after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: add-procedure ( -- )
+ basic-block get current-word get current-label get
+ <cfg> procedures get push ;
+
+: begin-procedure ( word label -- )
+ end-basic-block
+ begin-basic-block
+ H{ } clone loops set
+ current-label set
+ current-word set
+ add-procedure ;
+
+: with-cfg-builder ( nodes word label quot -- )
+ '[ begin-procedure @ ] with-scope ; inline
+
+GENERIC: emit-node ( node -- next )
+
+: check-basic-block ( node -- node' )
+ basic-block get [ drop f ] unless ; inline
+
+: emit-nodes ( nodes -- )
+ [ current-node emit-node check-basic-block ] iterate-nodes
+ finalize-phantoms ;
+
+: remember-loop ( label -- )
+ basic-block get swap loops get set-at ;
+
+: begin-word ( -- )
+ #! We store the basic block after the prologue as a loop
+ #! labelled by the current word, so that self-recursive
+ #! calls can skip an epilogue/prologue.
+ init-phantoms
+ ##prologue
+ ##branch
+ begin-basic-block
+ current-label get remember-loop ;
+
+: (build-cfg) ( nodes word label -- )
+ [
+ begin-word
+ [ emit-nodes ] with-node-iterator
+ ] with-cfg-builder ;
+
+: build-cfg ( nodes word -- procedures )
+ V{ } clone [
+ procedures [
+ dup (build-cfg)
+ ] with-variable
+ ] keep ;
+
+SYMBOL: +intrinsics+
+SYMBOL: +if-intrinsics+
+
+: if-intrinsics ( #call -- quot )
+ word>> +if-intrinsics+ word-prop ;
+
+: local-recursive-call ( basic-block -- next )
+ ##branch
+ basic-block get successors>> push
+ stop-iterating ;
+
+: emit-call ( word -- next )
+ finalize-phantoms
+ {
+ { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
+ { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+ [ ##epilogue ##jump stop-iterating ]
+ } cond ;
+
+! #recursive
+: compile-recursive ( node -- next )
+ [ label>> id>> emit-call ]
+ [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
+
+: compile-loop ( node -- next )
+ finalize-phantoms
+ 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 ;
+
+! #if
+: emit-branch ( obj quot -- final-bb )
+ '[
+ begin-basic-block copy-phantoms
+ @
+ basic-block get dup [ ##branch ] when
+ ] with-scope ;
+
+: emit-branches ( seq quot -- )
+ '[ _ emit-branch ] map
+ end-basic-block
+ begin-basic-block
+ basic-block get '[ [ _ swap successors>> push ] when* ] each
+ init-phantoms ;
+
+: emit-if ( node -- next )
+ children>> [ emit-nodes ] emit-branches ;
+
+M: #if emit-node
+ phantom-pop ##branch-t emit-if iterate-next ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+ #! The order here is important, dispatch-branches must
+ #! run after ##dispatch, so that each branch gets the
+ #! correct register state
+ gensym [
+ [
+ copy-phantoms
+ ##prologue
+ [ emit-nodes ] with-node-iterator
+ ##epilogue
+ ##return
+ ] with-cfg-builder
+ ] keep ;
+
+: dispatch-branches ( node -- )
+ children>> [
+ current-word get dispatch-branch
+ ##dispatch-label
+ ] each ;
+
+: emit-dispatch ( node -- )
+ phantom-pop int-regs next-vreg
+ [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
+ dispatch-branches init-phantoms ;
+
+M: #dispatch emit-node
+ tail-call? [
+ emit-dispatch iterate-next
+ ] [
+ current-word get gensym [
+ [
+ begin-word
+ emit-dispatch
+ ] with-cfg-builder
+ ] keep emit-call
+ ] if ;
+
+! #call
+: define-intrinsics ( word intrinsics -- )
+ +intrinsics+ set-word-prop ;
+
+: define-intrinsic ( word quot assoc -- )
+ 2array 1array define-intrinsics ;
+
+: define-if-intrinsics ( word intrinsics -- )
+ [ template new swap >>input ] assoc-map
+ +if-intrinsics+ set-word-prop ;
+
+: define-if-intrinsic ( word quot inputs -- )
+ 2array 1array define-if-intrinsics ;
+
+: find-intrinsic ( #call -- pair/f )
+ word>> +intrinsics+ word-prop find-template ;
+
+: find-boolean-intrinsic ( #call -- pair/f )
+ word>> +if-intrinsics+ word-prop find-template ;
+
+: find-if-intrinsic ( #call -- pair/f )
+ node@ {
+ { [ dup length 2 < ] [ 2drop f ] }
+ { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
+ [ 2drop f ]
+ } cond ;
+
+: do-if-intrinsic ( pair -- next )
+ [ ##if-intrinsic ] apply-template skip-next emit-if
+ iterate-next ;
+
+: do-boolean-intrinsic ( pair -- next )
+ [ ##if-intrinsic ] apply-template
+ { t f } [
+ <constant> phantom-push finalize-phantoms
+ ] emit-branches
+ iterate-next ;
+
+: do-intrinsic ( pair -- next )
+ [ ##intrinsic ] apply-template iterate-next ;
+
+: setup-value-classes ( #call -- )
+ node-input-infos [ class>> ] map set-value-classes ;
+
+{
+ (tuple) (array) (byte-array)
+ (complex) (ratio) (wrapper)
+ (write-barrier)
+} [ t "intrinsic" set-word-prop ] each
+
+: allot-size ( -- n )
+ 1 phantom-datastack get phantom-input first value>> ;
+
+:: emit-allot ( size type tag -- )
+ int-regs next-vreg
+ dup fresh-object
+ dup size type tag int-regs next-vreg ##allot
+ type tagged boa phantom-push ;
+
+: emit-write-barrier ( -- )
+ phantom-pop dup >vreg fresh-object? [ drop ] [
+ int-regs next-vreg ##write-barrier
+ ] if ;
+
+: emit-intrinsic ( word -- next )
+ {
+ { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
+ { \ (array) [ allot-size 2 cells + array object emit-allot ] }
+ { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
+ { \ (complex) [ 3 cells complex complex emit-allot ] }
+ { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
+ { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
+ { \ (write-barrier) [ emit-write-barrier ] }
+ } case
+ iterate-next ;
+
+M: #call emit-node
+ dup setup-value-classes
+ dup find-if-intrinsic [ do-if-intrinsic ] [
+ dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
+ dup find-intrinsic [ do-intrinsic ] [
+ word>> dup "intrinsic" word-prop
+ [ emit-intrinsic ] [ emit-call ] if
+ ] ?if
+ ] ?if
+ ] ?if ;
+
+! #call-recursive
+M: #call-recursive emit-node label>> id>> emit-call ;
+
+! #push
+M: #push emit-node
+ literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle emit-node
+ shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r emit-node
+ [ in-d>> length ] [ out-r>> empty? ] bi
+ [ phantom-drop ] [ phantom->r ] if
+ iterate-next ;
+
+M: #r> emit-node
+ [ in-r>> length ] [ out-d>> empty? ] bi
+ [ phantom-rdrop ] [ phantom-r> ] if
+ iterate-next ;
+
+! #return
+M: #return emit-node
+ drop finalize-phantoms ##epilogue ##return f ;
+
+M: #return-recursive emit-node
+ finalize-phantoms
+ label>> id>> loops get key?
+ [ ##epilogue ##return ] unless f ;
+
+! #terminate
+M: #terminate emit-node drop stop-iterating ;
+
+! FFI
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ {
+ { [ dup c-struct? not ] [ drop 0 ] }
+ { [ dup large-struct? not ] [ drop 2 cells ] }
+ [ heap-size ]
+ } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size ;
+
+: alien-stack-frame ( node -- )
+ params>> <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ [ drop alien-stack-frame ]
+ [ [ params>> ] dip call ] 2bi
+ iterate-next ; inline
+
+M: #alien-invoke emit-node
+ [ ##alien-invoke ] emit-alien-node ;
+
+M: #alien-indirect emit-node
+ [ ##alien-indirect ] emit-alien-node ;
+
+M: #alien-callback emit-node
+ params>> dup xt>> dup
+ [
+ init-phantoms
+ [ ##alien-callback ] emit-alien-node drop
+ ] with-cfg-builder
+ iterate-next ;
+
+! No-op nodes
+M: #introduce emit-node drop iterate-next ;
+
+M: #copy emit-node drop iterate-next ;
+
+M: #enter-recursive emit-node drop iterate-next ;
+
+M: #phi emit-node drop iterate-next ;
--- /dev/null
+Final stage of compilation generates machine code from dataflow IR
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sequences sets fry ;
+IN: compiler.cfg
+
+TUPLE: cfg entry word label ;
+
+C: <cfg> cfg
+
+! - "number" and "visited" is used by linearization.
+TUPLE: basic-block < identity-tuple
+visited
+number
+instructions
+successors ;
+
+: <basic-block> ( -- basic-block )
+ basic-block new
+ V{ } clone >>instructions
+ V{ } clone >>successors ;
+
+TUPLE: mr instructions word label ;
+
+: <mr> ( instructions word label -- mr )
+ mr new
+ swap >>label
+ swap >>word
+ swap >>instructions ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences quotations namespaces io
+accessors prettyprint prettyprint.config
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.linearization ;
+IN: compiler.cfg.debugger
+
+GENERIC: test-cfg ( quot -- cfgs )
+
+M: callable test-cfg
+ build-tree optimize-tree gensym build-cfg ;
+
+M: word test-cfg
+ [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
+
+: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
+
+: mr. ( mrs -- )
+ [
+ boa-tuples? on
+ "=== word: " write
+ dup word>> pprint
+ ", label: " write
+ dup label>> pprint nl nl
+ instructions>> .
+ nl
+ ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays kernel sequences namespaces
+math compiler.cfg.registers compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.instructions
+
+! Virtual CPU instructions, used by CFG and machine IRs
+
+TUPLE: ##cond-branch < insn src ;
+TUPLE: ##unary < insn dst src ;
+TUPLE: ##nullary < insn dst ;
+
+! Stack operations
+INSN: ##load-literal < ##nullary obj ;
+INSN: ##peek < ##nullary loc ;
+INSN: ##replace src loc ;
+INSN: ##inc-d n ;
+INSN: ##inc-r n ;
+
+! Subroutine calls
+TUPLE: stack-frame
+{ size integer }
+{ params integer }
+{ return integer }
+{ total-size integer } ;
+
+INSN: ##stack-frame stack-frame ;
+ : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##return ;
+
+INSN: ##intrinsic quot defs-vregs uses-vregs ;
+
+! Jump tables
+INSN: ##dispatch-label label ;
+INSN: ##dispatch src temp ;
+
+! Boxing and unboxing
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-f < ##unary ;
+INSN: ##unbox-alien < ##unary ;
+INSN: ##unbox-byte-array < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary ;
+INSN: ##box-float < ##unary temp ;
+INSN: ##box-alien < ##unary temp ;
+
+! Memory allocation
+INSN: ##allot < ##nullary size type tag temp ;
+INSN: ##write-barrier src temp ;
+INSN: ##gc ;
+
+! FFI
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+M: ##nullary defs-vregs dst>> >vreg 1array ;
+M: ##unary defs-vregs dst>> >vreg 1array ;
+M: ##write-barrier defs-vregs temp>> >vreg 1array ;
+
+: allot-defs-vregs ( insn -- seq )
+ [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
+
+M: ##box-float defs-vregs allot-defs-vregs ;
+M: ##box-alien defs-vregs allot-defs-vregs ;
+M: ##allot defs-vregs allot-defs-vregs ;
+M: ##dispatch defs-vregs temp>> >vreg 1array ;
+M: insn defs-vregs drop f ;
+
+M: ##replace uses-vregs src>> >vreg 1array ;
+M: ##unary uses-vregs src>> >vreg 1array ;
+M: ##write-barrier uses-vregs src>> >vreg 1array ;
+M: ##dispatch uses-vregs src>> >vreg 1array ;
+M: insn uses-vregs drop f ;
+
+: intrinsic-vregs ( assoc -- seq' )
+ [ nip >vreg ] { } assoc>map sift ;
+
+: intrinsic-defs-vregs ( insn -- seq )
+ defs-vregs>> intrinsic-vregs ;
+
+: intrinsic-uses-vregs ( insn -- seq )
+ uses-vregs>> intrinsic-vregs ;
+
+M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
+
+! Instructions used by CFG IR only.
+INSN: ##prologue ;
+INSN: ##epilogue ;
+
+INSN: ##branch ;
+INSN: ##branch-f < ##cond-branch ;
+INSN: ##branch-t < ##cond-branch ;
+INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
+
+M: ##cond-branch uses-vregs src>> >vreg 1array ;
+
+M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
+
+! Instructions used by machine IR only.
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
+
+INSN: _label id ;
+
+TUPLE: _cond-branch < insn src label ;
+
+INSN: _branch label ;
+INSN: _branch-f < _cond-branch ;
+INSN: _branch-t < _cond-branch ;
+INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
+
+M: _cond-branch uses-vregs src>> >vreg 1array ;
+
+M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
+
+INSN: _spill-integer src n ;
+INSN: _reload-integer dst n ;
+
+INSN: _spill-float src n ;
+INSN: _reload-float dst n ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.tuple classes.tuple.parser kernel words
+make fry sequences parser ;
+IN: compiler.cfg.instructions.syntax
+
+TUPLE: insn ;
+
+: INSN:
+ parse-tuple-definition "regs" suffix
+ [ dup tuple eq? [ drop insn ] when ] dip
+ [ define-tuple-class ]
+ [ 2drop save-location ]
+ [ 2drop dup '[ f _ boa , ] define-inline ]
+ 3tri ; parsing
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences kernel compiler.tree ;
+IN: compiler.cfg.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ first ;
+: iterate-next ( -- cursor ) node@ rest-slice ;
+: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+ over empty? [
+ 2drop
+ ] [
+ [ swap >node call node> drop ] keep iterate-nodes
+ ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+ >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+ [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+ [ t ] [
+ [
+ first
+ [ #return? ]
+ [ #return-recursive? ]
+ [ #terminate? ] tri or or
+ ] [ tail-phi? ] bi or
+ ] if-empty ;
+
+: tail-call? ( -- ? )
+ node-stack get [
+ rest-slice
+ [ t ] [
+ [ (tail-call?) ]
+ [ first #terminate? not ]
+ bi and
+ ] if-empty
+ ] all? ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences math math.order kernel assocs
+accessors vectors fry heaps
+compiler.cfg.registers
+compiler.cfg.linear-scan.live-intervals
+compiler.backend ;
+IN: compiler.cfg.linear-scan.allocation
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+ reg-class>> free-registers get at ;
+
+: deallocate-register ( live-interval -- )
+ [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+ active-intervals get push ;
+
+: delete-active ( live-interval -- )
+ active-intervals get delete ;
+
+: expire-old-intervals ( n -- )
+ active-intervals get
+ swap '[ end>> _ < ] partition
+ active-intervals set
+ [ deallocate-register ] each ;
+
+: expire-old-uses ( n -- )
+ active-intervals get
+ swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
+
+: update-state ( live-interval -- )
+ start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+ start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+ [ check-progress ]
+ [ dup start>> unhandled-intervals get heap-push ]
+ bi ;
+
+: init-unhandled ( live-intervals -- )
+ [ [ start>> ] keep ] { } map>assoc
+ unhandled-intervals get heap-push-all ;
+
+: assign-free-register ( live-interval registers -- )
+ #! If the live interval does not have any uses, it means it
+ #! will be spilled immediately, so it still needs a register
+ #! to compute the new value, but we don't add the interval
+ #! to the active set and we don't remove the register from
+ #! the free list.
+ over uses>> empty?
+ [ peek >>reg drop ] [ pop >>reg add-active ] if ;
+
+! Spilling
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+ spill-counts get [ dup 1+ ] change-at ;
+
+: interval-to-spill ( -- live-interval )
+ #! We spill the interval with the most distant use location.
+ active-intervals get unclip-slice [
+ [ [ uses>> peek ] bi@ > ] most
+ ] reduce ;
+
+: check-split ( live-interval -- )
+ [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
+
+: split-interval ( live-interval -- before after )
+ #! Split the live interval at the location of its first use.
+ #! 'Before' now starts and ends on the same instruction.
+ [ check-split ]
+ [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
+ [ clone f >>reg dup uses>> peek >>start ]
+ tri ;
+
+: record-split ( live-interval before after -- )
+ [ >>split-before ] [ >>split-after ] bi* drop ;
+
+: assign-spill ( before after -- before after )
+ #! If it has been spilled already, reuse spill location.
+ over reload-from>> [ next-spill-location ] unless*
+ tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
+
+: split-and-spill ( live-interval -- before after )
+ dup split-interval [ record-split ] [ assign-spill ] 2bi ;
+
+: reuse-register ( new existing -- )
+ reg>> >>reg
+ dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
+
+: spill-existing ( new existing -- )
+ #! Our new interval will be used before the active interval
+ #! with the most distant use location. Spill the existing
+ #! interval, then process the new interval and the tail end
+ #! of the existing interval again.
+ [ reuse-register ]
+ [ delete-active ]
+ [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
+
+: spill-new ( new existing -- )
+ #! Our new interval will be used after the active interval
+ #! with the most distant use location. Split the new
+ #! interval, then process both parts of the new interval
+ #! again.
+ [ split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+ over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
+
+: assign-blocked-register ( live-interval -- )
+ interval-to-spill
+ 2dup spill-existing?
+ [ spill-existing ] [ spill-new ] if ;
+
+: assign-register ( live-interval -- )
+ dup vreg>> free-registers-for [
+ assign-blocked-register
+ ] [
+ assign-free-register
+ ] if-empty ;
+
+! Main loop
+: init-allocator ( registers -- )
+ V{ } clone active-intervals set
+ <min-heap> unhandled-intervals set
+ [ reverse >vector ] assoc-map free-registers set
+ H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
+ -1 progress set ;
+
+: handle-interval ( live-interval -- )
+ [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
+
+: (allocate-registers) ( -- )
+ unhandled-intervals get [ handle-interval ] slurp-heap ;
+
+: allocate-registers ( live-intervals machine-registers -- live-intervals )
+ #! This modifies the input live-intervals.
+ init-allocator
+ dup init-unhandled
+ (allocate-registers) ;
--- /dev/null
+USING: compiler.cfg.linear-scan.assignment tools.test ;
+IN: compiler.cfg.linear-scan.assignment.tests
+
+\ assign-registers must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math assocs namespaces sequences heaps
+fry make combinators
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.assignment
+
+! A vector of live intervals. There is linear searching involved
+! 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
+
+: add-active ( live-interval -- )
+ active-intervals get push ;
+
+: lookup-register ( vreg -- reg )
+ active-intervals get [ vreg>> = ] with find nip reg>> ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+: add-unhandled ( live-interval -- )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ add-unhandled ] bi@
+ ] [
+ dup start>> unhandled-intervals get heap-push
+ ] if ;
+
+: init-unhandled ( live-intervals -- )
+ [ add-unhandled ] each ;
+
+: insert-spill ( live-interval -- )
+ [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
+ over [
+ {
+ { int-regs [ _spill-integer ] }
+ { double-float-regs [ _spill-float ] }
+ } case
+ ] [ 3drop ] if ;
+
+: expire-old-intervals ( n -- )
+ active-intervals get
+ swap '[ end>> _ = ] partition
+ active-intervals set
+ [ insert-spill ] each ;
+
+: insert-reload ( live-interval -- )
+ [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
+ over [
+ {
+ { int-regs [ _reload-integer ] }
+ { double-float-regs [ _reload-float ] }
+ } case
+ ] [ 3drop ] if ;
+
+: activate-new-intervals ( n -- )
+ #! Any live intervals which start on the current instruction
+ #! are added to the active set.
+ unhandled-intervals get dup heap-empty? [ 2drop ] [
+ 2dup heap-peek drop start>> = [
+ heap-pop drop [ add-active ] [ insert-reload ] bi
+ activate-new-intervals
+ ] [ 2drop ] if
+ ] if ;
+
+: (assign-registers) ( insn -- )
+ dup
+ [ defs-vregs ] [ uses-vregs ] bi append
+ active-intervals get swap '[ vreg>> _ member? ] filter
+ [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+ >>regs drop ;
+
+: init-assignment ( live-intervals -- )
+ V{ } clone active-intervals set
+ <min-heap> unhandled-intervals set
+ init-unhandled ;
+
+: assign-registers ( insns live-intervals -- insns' )
+ [
+ init-assignment
+ [
+ [ activate-new-intervals ]
+ [ drop [ (assign-registers) ] [ , ] bi ]
+ [ expire-old-intervals ]
+ tri
+ ] each-index
+ ] { } make ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences sets arrays
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation ;
+IN: compiler.cfg.linear-scan.debugger
+
+: check-assigned ( live-intervals -- )
+ [
+ reg>>
+ [ "Not all intervals have registers" throw ] unless
+ ] each ;
+
+: split-children ( live-interval -- seq )
+ dup split-before>> [
+ [ split-before>> ] [ split-after>> ] bi
+ [ split-children ] bi@
+ append
+ ] [ 1array ] if ;
+
+: check-linear-scan ( live-intervals machine-registers -- )
+ [ [ clone ] map ] dip allocate-registers
+ [ split-children ] map concat check-assigned ;
--- /dev/null
+IN: compiler.cfg.linear-scan.tests
+USING: tools.test random sorting sequences sets hashtables assocs
+kernel fry arrays splitting namespaces math accessors vectors
+math.order
+compiler.cfg.registers
+compiler.cfg.linear-scan
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.debugger ;
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[ ] [
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] unit-test
+
+[
+ {
+ T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+ T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
+ }
+ H{ { f { "A" } } }
+ check-linear-scan
+] must-fail
+
+SYMBOL: available
+
+SYMBOL: taken
+
+SYMBOL: max-registers
+
+SYMBOL: max-insns
+
+SYMBOL: max-uses
+
+: not-taken ( -- n )
+ available get keys dup empty? [ "Oops" throw ] when
+ random
+ dup taken get nth 1 + max-registers get = [
+ dup available get delete-at
+ ] [
+ dup taken get [ 1 + ] change-nth
+ ] if ;
+
+: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
+ [
+ max-insns set
+ max-registers set
+ max-uses set
+ max-insns get [ 0 ] replicate taken set
+ max-insns get [ dup ] H{ } map>assoc available set
+ [
+ live-interval new
+ swap f swap vreg boa >>vreg
+ max-uses get random 2 max [ not-taken ] replicate natural-sort
+ unclip [ >vector >>uses ] [ >>start ] bi*
+ dup uses>> first >>end
+ ] map
+ ] with-scope ;
+
+: random-test ( num-intervals max-uses max-registers max-insns -- )
+ over >r random-live-intervals r> f associate check-linear-scan ;
+
+[ ] [ 30 2 1 60 random-test ] unit-test
+[ ] [ 60 2 2 60 random-test ] unit-test
+[ ] [ 80 2 3 200 random-test ] unit-test
+[ ] [ 70 2 5 30 random-test ] unit-test
+[ ] [ 60 2 6 30 random-test ] unit-test
+[ ] [ 1 2 10 10 random-test ] unit-test
+
+[ ] [ 10 4 2 60 random-test ] unit-test
+[ ] [ 10 20 2 400 random-test ] unit-test
+[ ] [ 10 20 4 300 random-test ] unit-test
+
+USING: math.private compiler.cfg.debugger ;
+
+[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces
+compiler.backend
+compiler.cfg
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.assignment ;
+IN: compiler.cfg.linear-scan
+
+! References:
+
+! Linear Scan Register Allocation
+! by Massimiliano Poletto and Vivek Sarkar
+! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! Linear Scan Register Allocation for the Java HotSpot Client Compiler
+! by Christian Wimmer
+! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
+
+! Quality and Speed in Linear-scan Register Allocation
+! by Omri Traub, Glenn Holloway, Michael D. Smith
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+
+: linear-scan ( mr -- mr' )
+ [
+ [
+ dup compute-live-intervals
+ machine-registers allocate-registers
+ assign-registers
+ ] change-instructions
+ spill-counts get >>spill-counts
+ ] with-scope ;
--- /dev/null
+! Copyright (C) 2008 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 ;
+IN: compiler.cfg.linear-scan.live-intervals
+
+TUPLE: live-interval < identity-tuple
+vreg
+reg spill-to reload-from split-before split-after
+start end uses ;
+
+: <live-interval> ( start vreg -- live-interval )
+ live-interval new
+ swap >>vreg
+ swap >>start
+ V{ } clone >>uses ;
+
+M: live-interval hashcode*
+ nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+M: live-interval clone
+ call-next-method [ clone ] change-uses ;
+
+! Mapping from vreg to live-interval
+SYMBOL: live-intervals
+
+: add-use ( n vreg live-intervals -- )
+ at [ (>>end) ] [ uses>> push ] 2bi ;
+
+: new-live-interval ( n vreg live-intervals -- )
+ 2dup key? [ "Multiple defs" throw ] when
+ [ [ <live-interval> ] keep ] dip set-at ;
+
+: compute-live-intervals* ( insn n -- )
+ live-intervals get
+ [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
+ [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+ 3bi ;
+
+: finalize-live-intervals ( assoc -- seq' )
+ #! Reverse uses lists so that we can pop values off.
+ values dup [ uses>> reverse-here ] each ;
+
+: compute-live-intervals ( instructions -- live-intervals )
+ H{ } clone [
+ live-intervals set
+ [ compute-live-intervals* ] each-index
+ ] keep finalize-live-intervals ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces make
+combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
+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
+
+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>> 1+ ] [ number>> ] bi* = ; inline
+
+: branch-to-return? ( successor -- ? )
+ #! A branch to a block containing just a return is cloned.
+ instructions>> dup length 2 = [
+ [ first ##epilogue? ] [ second ##return? ] bi and
+ ] [ drop f ] if ;
+
+: emit-branch ( basic-block successor -- )
+ {
+ { [ 2dup useless-branch? ] [ 2drop ] }
+ { [ dup branch-to-return? ] [ nip linearize-insns ] }
+ [ nip number>> _branch ]
+ } cond ;
+
+M: ##branch linearize-insn
+ drop dup successors>> first emit-branch ;
+
+: conditional ( basic-block -- basic-block successor1 label2 )
+ dup successors>> first2 swap number>> ; inline
+
+: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
+ [ conditional ] [ src>> ] bi* swap ; inline
+
+M: ##branch-f linearize-insn
+ boolean-conditional _branch-f emit-branch ;
+
+M: ##branch-t linearize-insn
+ boolean-conditional _branch-t emit-branch ;
+
+: >intrinsic< ( insn -- quot defs uses )
+ [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
+
+M: ##if-intrinsic linearize-insn
+ [ conditional ] [ >intrinsic< ] bi*
+ _if-intrinsic emit-branch ;
+
+: linearize-basic-block ( bb -- )
+ [ number>> _label ] [ linearize-insns ] bi ;
+
+: 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> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces math kernel alien classes ;
+IN: compiler.cfg.registers
+
+! Virtual CPU registers, used by CFG and machine IRs
+
+MIXIN: value
+
+GENERIC: >vreg ( obj -- vreg )
+GENERIC: set-value-class ( class obj -- )
+GENERIC: value-class* ( operand -- class )
+
+: value-class ( operand -- class ) value-class* object or ;
+
+M: value >vreg drop f ;
+M: value set-value-class 2drop ;
+M: value value-class* drop f ;
+
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
+
+! Virtual registers
+TUPLE: vreg reg-class n ;
+SYMBOL: vreg-counter
+: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+
+M: vreg >vreg ;
+
+INSTANCE: vreg value
+
+! Stack locations
+TUPLE: loc n class ;
+
+! A data stack location.
+TUPLE: ds-loc < loc ;
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+TUPLE: rs-loc < loc ;
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+
+INSTANCE: loc value
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+C: <cached> cached
+
+M: cached set-value-class vreg>> set-value-class ;
+M: cached value-class* vreg>> value-class* ;
+M: cached >vreg vreg>> >vreg ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+: <tagged> ( vreg -- tagged ) f tagged boa ;
+
+M: tagged set-value-class (>>class) ;
+M: tagged value-class* class>> ;
+M: tagged >vreg vreg>> ;
+
+INSTANCE: tagged value
+
+! Unboxed value
+TUPLE: unboxed vreg ;
+C: <unboxed> unboxed
+
+M: unboxed >vreg vreg>> ;
+
+INSTANCE: unboxed value
+
+! Unboxed alien pointer
+TUPLE: unboxed-alien < unboxed ;
+C: <unboxed-alien> unboxed-alien
+
+M: unboxed-alien value-class* drop simple-alien ;
+
+! Untagged byte array pointer
+TUPLE: unboxed-byte-array < unboxed ;
+C: <unboxed-byte-array> unboxed-byte-array
+
+M: unboxed-byte-array value-class* drop c-ptr ;
+
+! A register set to f
+TUPLE: unboxed-f < unboxed ;
+C: <unboxed-f> unboxed-f
+
+M: unboxed-f value-class* drop \ f ;
+
+! An alien, byte array or f
+TUPLE: unboxed-c-ptr < unboxed ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+
+M: unboxed-c-ptr value-class* drop c-ptr ;
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+
+M: constant value-class* value>> class ;
+
+INSTANCE: constant value
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces make math sequences
+compiler.cfg.instructions ;
+IN: compiler.cfg.rpo
+
+: post-order-traversal ( basic-block -- )
+ dup visited>> [ drop ] [
+ t >>visited
+ [ successors>> [ post-order-traversal ] each ] [ , ] bi
+ ] if ;
+
+: post-order ( procedure -- blocks )
+ [ post-order-traversal ] { } make ;
+
+: number-blocks ( blocks -- )
+ [ >>number drop ] each-index ;
+
+: reverse-post-order ( procedure -- blocks )
+ post-order <reversed> dup number-blocks ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+make compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.registers ;
+IN: compiler.cfg.stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: spill-counts
+
+: init-stack-frame-builder ( -- )
+ frame-required? off
+ T{ stack-frame } clone stack-frame set ;
+
+GENERIC: compute-stack-frame* ( insn -- )
+
+: max-stack-frame ( frame1 frame2 -- frame3 )
+ {
+ [ [ size>> ] bi@ max ]
+ [ [ params>> ] bi@ max ]
+ [ [ return>> ] bi@ max ]
+ [ [ total-size>> ] bi@ max ]
+ } cleave
+ stack-frame boa ;
+
+M: ##stack-frame compute-stack-frame*
+ frame-required? on
+ stack-frame>> stack-frame [ max-stack-frame ] change ;
+
+M: _spill-integer compute-stack-frame*
+ drop frame-required? on ;
+
+M: _spill-float compute-stack-frame*
+ drop frame-required? on ;
+
+M: insn compute-stack-frame* drop ;
+
+: compute-stack-frame ( insns -- )
+ [ compute-stack-frame* ] each ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##stack-frame insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+ [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+ [
+ init-stack-frame-builder
+ [
+ [ compute-stack-frame ]
+ [ insert-pro/epilogues ]
+ bi
+ ] change-instructions
+ ] with-scope ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators hashtables kernel layouts math fry namespaces
+quotations sequences system vectors words effects alien
+byte-arrays accessors sets math.order compiler.backend
+compiler.cfg.instructions compiler.cfg.registers ;
+IN: compiler.cfg.stacks
+
+! Converting stack operations into register operations, while
+! doing a bit of optimization along the way.
+SYMBOL: known-tag
+
+! Value protocol
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC# (eager-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+PRIVATE>
+
+! Default implementation
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+M: vreg move-spec reg-class>> move-spec ;
+M: vreg value-class* reg-class>> value-class* ;
+
+M: int-regs move-spec drop f ;
+M: int-regs value-class* drop object ;
+
+M: float-regs move-spec drop float ;
+M: float-regs value-class* drop float ;
+
+M: ds-loc minimal-ds-loc* n>> min ;
+M: ds-loc live-loc?
+ over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
+
+M: rs-loc live-loc?
+ over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
+
+M: loc value-class* class>> ;
+M: loc set-value-class (>>class) ;
+M: loc move-spec drop loc ;
+
+M: f move-spec drop loc ;
+M: f value-class* ;
+
+M: cached move-spec drop cached ;
+M: cached live-loc? loc>> live-loc? ;
+M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
+M: cached (eager-load) >r vreg>> r> (eager-load) ;
+M: cached lazy-store
+ 2dup loc>> live-loc?
+ [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
+
+M: tagged move-spec drop f ;
+
+M: unboxed-alien move-spec class ;
+
+M: unboxed-byte-array move-spec class ;
+
+M: unboxed-f move-spec class ;
+
+M: unboxed-c-ptr move-spec class ;
+
+M: constant move-spec class ;
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+ dup value-class {
+ { [ dup \ f class<= ] [ drop ##unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+ [ drop ##unbox-any-c-ptr ]
+ } cond ; inline
+
+: %move-via-temp ( dst src -- )
+ #! For many transfers, such as loc to unboxed-alien, we
+ #! don't have an intrinsic, so we transfer the source to
+ #! temp then temp to the destination.
+ int-regs next-vreg [ over %move value-class ] keep
+ tagged new
+ swap >>vreg
+ swap >>class
+ %move ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+: fresh-object ( vreg/t -- ) fresh-objects get push ;
+
+: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
+
+: %move ( dst src -- )
+ 2dup [ move-spec ] bi@ 2array {
+ { { f f } [ ##copy ] }
+ { { unboxed-alien unboxed-alien } [ ##copy ] }
+ { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
+ { { unboxed-f unboxed-f } [ ##copy ] }
+ { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
+ { { float float } [ ##copy-float ] }
+
+ { { f unboxed-c-ptr } [ %move-bug ] }
+ { { f unboxed-byte-array } [ %move-bug ] }
+
+ { { f constant } [ value>> ##load-literal ] }
+
+ { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
+ { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
+ { { f loc } [ ##peek ] }
+
+ { { float f } [ ##unbox-float ] }
+ { { unboxed-alien f } [ ##unbox-alien ] }
+ { { unboxed-byte-array f } [ ##unbox-byte-array ] }
+ { { unboxed-f f } [ ##unbox-f ] }
+ { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+ { { loc f } [ swap ##replace ] }
+
+ [ drop %move-via-temp ]
+ } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+ #! Utility for methods on <loc>
+ height>> - ;
+
+: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
+ '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+ \ ##inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+ \ ##inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or rs-locs indexing the stack.
+ >r <reversed> r> '[ _ <loc> ] map ;
+
+: phantom-locs* ( phantom -- locs )
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+ phantoms 2array swap '[ _ (each-loc) ] each ; inline
+
+: adjust-phantom ( n phantom -- )
+ swap '[ _ + ] change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+ swap '[ _ cut* swap ] change-stack drop ;
+
+: phantom-append ( seq stack -- )
+ over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+ 2dup stack>> length <= [
+ 2drop
+ ] [
+ [ phantom-locs ] keep
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
+ ] if ;
+
+: phantom-input ( n phantom -- seq )
+ 2dup add-locs
+ 2dup cut-phantom
+ >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: (live-locs) ( phantom -- seq )
+ #! Discard locs which haven't moved
+ [ phantom-locs* ] [ stack>> ] bi zip
+ [ live-loc? ] assoc-filter
+ values ;
+
+: live-locs ( -- seq )
+ [ (live-locs) ] each-phantom append prune ;
+
+: reg-spec>class ( spec -- class )
+ float eq? double-float-regs int-regs ? ;
+
+: alloc-vreg ( spec -- reg )
+ [ reg-spec>class next-vreg ] keep {
+ { f [ <tagged> ] }
+ { unboxed-alien [ <unboxed-alien> ] }
+ { unboxed-byte-array [ <unboxed-byte-array> ] }
+ { unboxed-f [ <unboxed-f> ] }
+ { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+ [ drop ]
+ } case ;
+
+: compatible? ( value spec -- ? )
+ >r move-spec r> {
+ { [ 2dup = ] [ t ] }
+ { [ dup unboxed-c-ptr eq? ] [
+ over { unboxed-byte-array unboxed-alien } member?
+ ] }
+ [ f ]
+ } cond 2nip ;
+
+: alloc-vreg-for ( value spec -- vreg )
+ alloc-vreg swap value-class
+ over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+ {
+ { [ dup { small-slot small-tagged } memq? ] [ drop ] }
+ { [ 2dup compatible? ] [ drop ] }
+ [ (eager-load) ]
+ } cond ;
+
+M: value (eager-load) ( value spec -- vreg )
+ [ alloc-vreg-for ] [ drop ] 2bi
+ [ %move ] [ drop ] 2bi ;
+
+M: loc lazy-store
+ 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: finalize-locs ( -- )
+ #! Perform any deferred stack shuffling.
+ live-locs [ dup f (lazy-load) ] H{ } map>assoc
+ dup assoc-empty? [ drop ] [
+ "live-locs" set [ lazy-store ] each-loc
+ ] if ;
+
+: finalize-vregs ( -- )
+ #! Store any vregs to their final stack locations.
+ [
+ dup loc? over cached? or [ 2drop ] [ %move ] if
+ ] each-loc ;
+
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
+
+: finalize-contents ( -- )
+ finalize-locs finalize-vregs clear-phantoms ;
+
+! Loading stacks to vregs
+: vreg-substitution ( value vreg -- pair )
+ dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+ #! We don't substitute locs for float or alien vregs,
+ #! since in those cases the boxing overhead might kill us.
+ vreg>> tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+ [ vreg-substitution ] 2map
+ [ substitute-vreg? ] assoc-filter >hashtable
+ '[ stack>> _ substitute-here ] each-phantom ;
+
+: set-value-classes ( classes -- )
+ phantom-datastack get
+ over length over add-locs
+ stack>> [
+ [ value-class class-and ] keep set-value-class
+ ] 2reverse-each ;
+
+: finalize-phantoms ( -- )
+ #! Commit all deferred stacking shuffling, and ensure the
+ #! in-memory data and retain stacks are up to date with
+ #! respect to the compiler's current picture.
+ finalize-contents
+ finalize-heights
+ fresh-objects get [
+ empty? [ ##simple-stack-frame ##gc ] unless
+ ] [ delete-all ] bi ;
+
+: init-phantoms ( -- )
+ V{ } clone fresh-objects set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set ;
+
+: copy-phantoms ( -- )
+ fresh-objects [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change ;
+
+: phantom-push ( obj -- )
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+ [ in>> length phantom-datastack get phantom-input ] keep
+ shuffle phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
+
+: phantom-drop ( n -- )
+ phantom-datastack get phantom-input drop ;
+
+: phantom-rdrop ( n -- )
+ phantom-retainstack get phantom-input drop ;
+
+: phantom-pop ( -- vreg )
+ 1 phantom-datastack get phantom-input dup first f (lazy-load)
+ [ 1array substitute-vregs ] keep ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors sequences kernel fry namespaces
+quotations combinators classes.algebra compiler.backend
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
+IN: compiler.cfg.templates
+
+TUPLE: template input output scratch clobber gc ;
+
+: phantom&spec ( phantom specs -- phantom' specs' )
+ >r stack>> r>
+ [ length f pad-left ] keep
+ [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+ >r phantom&spec r> 2all? ; inline
+
+: live-vregs ( -- seq )
+ [ stack>> [ >vreg ] map sift ] each-phantom append ;
+
+: clobbered ( template -- seq )
+ [ output>> ] [ clobber>> ] bi append ;
+
+: clobbered? ( value name -- ? )
+ \ clobbered get member? [
+ >vreg \ live-vregs get member?
+ ] [ drop f ] if ;
+
+: lazy-load ( specs -- seq )
+ [ length phantom-datastack get phantom-input ] keep
+ [
+ 2dup second clobbered?
+ [ first (eager-load) ] [ first (lazy-load) ] if
+ ] 2map ;
+
+: load-inputs ( template -- assoc )
+ [
+ live-vregs \ live-vregs set
+ dup clobbered \ clobbered set
+ input>> [ values ] [ lazy-load ] bi zip
+ ] with-scope ;
+
+: alloc-scratch ( template -- assoc )
+ scratch>> [ swap alloc-vreg ] assoc-map ;
+
+: do-template-inputs ( template -- defs uses )
+ #! Load input values into registers and allocates scratch
+ #! registers.
+ [ alloc-scratch ] [ load-inputs ] bi ;
+
+: do-template-outputs ( template defs uses -- )
+ [ output>> ] 2dip assoc-union '[ _ at ] map
+ phantom-datastack get phantom-append ;
+
+: apply-template ( pair quot -- vregs )
+ [
+ first2
+ dup gc>> [ t fresh-object ] when
+ dup do-template-inputs
+ [ do-template-outputs ] 2keep
+ ] dip call ; inline
+
+: value-matches? ( value spec -- ? )
+ #! If the spec is a quotation and the value is a literal
+ #! fixnum, see if the quotation yields true when applied
+ #! to the fixnum. Otherwise, the values don't match. If the
+ #! spec is not a quotation, its a reg-class, in which case
+ #! the value is always good.
+ {
+ { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
+ { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
+ [ 2drop t ]
+ } cond ;
+
+: class-matches? ( actual expected -- ? )
+ {
+ { f [ drop t ] }
+ { known-tag [ dup [ class-tag >boolean ] when ] }
+ [ class<= ]
+ } case ;
+
+: spec-matches? ( value spec -- ? )
+ 2dup first value-matches?
+ >r >r value-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( template -- ? )
+ input>> phantom-datastack get swap
+ [ spec-matches? ] phantom&spec-agree? ;
+
+: find-template ( templates -- pair/f )
+ #! Pair has shape { quot assoc }
+ [ second template-matches? ] find nip ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces make math math.parser sequences accessors
+kernel kernel.private layouts assocs words summary arrays
+combinators classes.algebra alien alien.c-types alien.structs
+alien.strings sets threads libc continuations.private
+compiler.errors
+compiler.alien
+compiler.backend
+compiler.codegen.fixup
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.builder ;
+IN: compiler.codegen
+
+GENERIC: generate-insn ( insn -- )
+
+GENERIC: v>operand ( obj -- operand )
+
+SYMBOL: registers
+
+M: constant v>operand
+ value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+M: value v>operand
+ >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+
+: generate-insns ( insns -- code )
+ [
+ [
+ dup regs>> registers set
+ generate-insn
+ ] each
+ ] { } make fixup ;
+
+TUPLE: asm label code calls ;
+
+SYMBOL: calls
+
+: add-call ( word -- )
+ #! Compile this word later.
+ calls get push ;
+
+SYMBOL: compiling-word
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+! Mapping _label IDs to label instances
+SYMBOL: labels
+
+: 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 f ? add-literal drop ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ]
+ [ word>> init-generator ]
+ [ instructions>> generate-insns ] tri
+ calls get
+ asm boa
+ ] with-scope ;
+
+: lookup-label ( id -- label )
+ labels get [ drop <label> ] cache ;
+
+M: _label generate-insn
+ id>> lookup-label , ;
+
+M: _prologue generate-insn
+ stack-frame>>
+ [ stack-frame set ]
+ [ dup size>> stack-frame-size >>total-size drop ]
+ [ total-size>> %prologue ]
+ tri ;
+
+M: _epilogue generate-insn
+ stack-frame>> total-size>> %epilogue ;
+
+M: ##load-literal generate-insn
+ [ obj>> ] [ dst>> v>operand ] bi load-literal ;
+
+M: ##peek generate-insn
+ [ dst>> v>operand ] [ loc>> ] bi %peek ;
+
+M: ##replace generate-insn
+ [ src>> ] [ loc>> ] bi %replace ;
+
+M: ##inc-d generate-insn n>> %inc-d ;
+
+M: ##inc-r generate-insn n>> %inc-r ;
+
+M: ##return generate-insn drop %return ;
+
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+
+M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+
+SYMBOL: operands
+
+: init-intrinsic ( insn -- )
+ [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
+
+M: ##intrinsic generate-insn
+ [ init-intrinsic ] [ quot>> call ] bi ;
+
+: (operand) ( name -- operand )
+ operands get at* [ "Bad operand name" throw ] unless ;
+
+: operand ( name -- operand )
+ (operand) v>operand ;
+
+: operand-class ( var -- class )
+ (operand) value-class ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: unique-operands ( operands quot -- )
+ >r [ operand ] map prune r> each ; inline
+
+M: _if-intrinsic generate-insn
+ [ init-intrinsic ]
+ [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
+
+M: _branch generate-insn
+ label>> lookup-label %jump-label ;
+
+M: _branch-f generate-insn
+ [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
+
+M: _branch-t generate-insn
+ [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn drop %dispatch ;
+
+: dst/src ( insn -- dst src )
+ [ dst>> v>operand ] [ src>> v>operand ] bi ;
+
+M: ##copy generate-insn dst/src %copy ;
+
+M: ##copy-float generate-insn dst/src %copy-float ;
+
+M: ##unbox-float generate-insn dst/src %unbox-float ;
+
+M: ##unbox-f generate-insn dst/src %unbox-f ;
+
+M: ##unbox-alien generate-insn dst/src %unbox-alien ;
+
+M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+
+M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+
+M: ##box-float generate-insn dst/src %box-float ;
+
+M: ##box-alien generate-insn dst/src %box-alien ;
+
+M: ##allot generate-insn
+ {
+ [ dst>> v>operand ]
+ [ size>> ]
+ [ type>> ]
+ [ tag>> ]
+ [ temp>> v>operand ]
+ } cleave
+ %allot ;
+
+M: ##write-barrier generate-insn
+ [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
+
+M: ##gc generate-insn drop %gc ;
+
+! #alien-invoke
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+GENERIC: reg-class-full? ( class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: object reg-class-full?
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- seq )
+ cell /i "void*" c-type <repetition> ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+
+M: struct-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- types )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) % ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type %
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+ params>>
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ ! Box return value
+ dup %cleanup
+ box-return* ;
+
+! ##alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces make sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitwise words.private math.order accessors
+growable compiler.constants compiler.backend ;
+IN: compiler.codegen.fixup
+
+GENERIC: fixup* ( obj -- )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+M: label fixup* compiled-offset >>offset drop ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+ dup class>> rc-absolute?
+ [ "Absolute labels not supported" throw ] when
+ [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+ 3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+ 2dup swap [ eq? ] curry find drop
+ [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+ >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+ >r literal-table get length >r
+ add-dlsym-literals
+ r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+ >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+ >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+ >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+ 0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+ 0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+ BV{ } clone relocation-table set
+ V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+ [
+ first3 offset>>
+ [ "Unresolved label" throw ] unless*
+ 3array
+ ] map concat ;
+
+: fixup ( fixup-directives -- code )
+ [
+ init-fixup
+ [ fixup* ] each
+ literal-table get >array
+ relocation-table get >byte-array
+ label-table get resolve-labels
+ ] { } make 4array ;
--- /dev/null
+Support for generation of relocatable code
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs cpu.architecture ;
-IN: compiler.alien
-
-: large-struct? ( ctype -- ? )
- dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
-
-: alien-parameters ( params -- seq )
- dup parameters>>
- swap return>> large-struct? [ "void*" prefix ] when ;
-
-: alien-return ( params -- ctype )
- return>> dup large-struct? [ drop "void" ] when ;
-
-: c-type-stack-align ( type -- align )
- dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
-
-: parameter-align ( n type -- n delta )
- over >r c-type-stack-align align dup r> - ;
-
-: parameter-sizes ( types -- total offsets )
- #! Compute stack frame locations.
- [
- 0 [
- [ parameter-align drop dup , ] keep stack-size +
- ] reduce cell align
- ] { } make ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: compiler.cfg.builder.tests
-USING: tools.test kernel sequences
-words sequences.private fry prettyprint alien
-math.private compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.debugger ;
-
-! Just ensure that various CFGs build correctly.
-{
- [ ]
- [ dup ]
- [ swap ]
- [ >r r> ]
- [ fixnum+ ]
- [ fixnum< ]
- [ [ 1 ] [ 2 ] if ]
- [ fixnum< [ 1 ] [ 2 ] if ]
- [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
- [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
- [ [ t ] loop ]
- [ [ dup ] loop ]
- [ [ 2 ] [ 3 throw ] if 4 ]
- [ "int" f "malloc" { "int" } alien-invoke ]
- [ "int" { "int" } "cdecl" alien-indirect ]
- [ "int" { "int" } "cdecl" [ ] alien-callback ]
-} [
- '[ _ test-cfg drop ] [ ] swap unit-test
-] each
-
-: test-1 ( -- ) test-1 ;
-: test-2 ( -- ) 3 . test-2 ;
-: test-3 ( a -- b ) dup [ test-3 ] when ;
-
-{
- test-1
- test-2
- test-3
-} [
- '[ _ test-cfg drop ] [ ] swap unit-test
-] each
+++ /dev/null
- ! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators hashtables kernel
-math fry namespaces make sequences words byte-arrays
-locals layouts alien.c-types alien.structs
-stack-checker.inlining
-compiler.intrinsics
-compiler.tree
-compiler.tree.builder
-compiler.tree.combinators
-compiler.tree.propagation.info
-compiler.cfg
-compiler.cfg.stacks
-compiler.cfg.templates
-compiler.cfg.iterator
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.alien ;
-IN: compiler.cfg.builder
-
-! Convert tree SSA IR to CFG (not quite SSA yet) IR.
-
-: set-basic-block ( basic-block -- )
- [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
- <basic-block> basic-block get [
- dupd successors>> push
- ] when*
- set-basic-block ;
-
-: end-basic-block ( -- )
- building off
- basic-block off ;
-
-: stop-iterating ( -- next ) end-basic-block f ;
-
-SYMBOL: procedures
-SYMBOL: current-word
-SYMBOL: current-label
-SYMBOL: loops
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: add-procedure ( -- )
- basic-block get current-word get current-label get
- <cfg> procedures get push ;
-
-: begin-procedure ( word label -- )
- end-basic-block
- begin-basic-block
- H{ } clone loops set
- current-label set
- current-word set
- add-procedure ;
-
-: with-cfg-builder ( nodes word label quot -- )
- '[ begin-procedure @ ] with-scope ; inline
-
-GENERIC: emit-node ( node -- next )
-
-: check-basic-block ( node -- node' )
- basic-block get [ drop f ] unless ; inline
-
-: emit-nodes ( nodes -- )
- [ current-node emit-node check-basic-block ] iterate-nodes
- finalize-phantoms ;
-
-: remember-loop ( label -- )
- basic-block get swap loops get set-at ;
-
-: begin-word ( -- )
- #! We store the basic block after the prologue as a loop
- #! labelled by the current word, so that self-recursive
- #! calls can skip an epilogue/prologue.
- init-phantoms
- ##prologue
- ##branch
- begin-basic-block
- current-label get remember-loop ;
-
-: (build-cfg) ( nodes word label -- )
- [
- begin-word
- [ emit-nodes ] with-node-iterator
- ] with-cfg-builder ;
-
-: build-cfg ( nodes word -- procedures )
- V{ } clone [
- procedures [
- dup (build-cfg)
- ] with-variable
- ] keep ;
-
-SYMBOL: +intrinsics+
-SYMBOL: +if-intrinsics+
-
-: if-intrinsics ( #call -- quot )
- word>> +if-intrinsics+ word-prop ;
-
-: local-recursive-call ( basic-block -- next )
- ##branch
- basic-block get successors>> push
- stop-iterating ;
-
-: emit-call ( word -- next )
- finalize-phantoms
- {
- { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
- { [ dup loops get key? ] [ loops get at local-recursive-call ] }
- [ ##epilogue ##jump stop-iterating ]
- } cond ;
-
-! #recursive
-: compile-recursive ( node -- next )
- [ label>> id>> emit-call ]
- [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
-
-: compile-loop ( node -- next )
- finalize-phantoms
- 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 ;
-
-! #if
-: emit-branch ( obj quot -- final-bb )
- '[
- begin-basic-block copy-phantoms
- @
- basic-block get dup [ ##branch ] when
- ] with-scope ;
-
-: emit-branches ( seq quot -- )
- '[ _ emit-branch ] map
- end-basic-block
- begin-basic-block
- basic-block get '[ [ _ swap successors>> push ] when* ] each
- init-phantoms ;
-
-: emit-if ( node -- next )
- children>> [ emit-nodes ] emit-branches ;
-
-M: #if emit-node
- phantom-pop ##branch-t emit-if iterate-next ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
- #! The order here is important, dispatch-branches must
- #! run after ##dispatch, so that each branch gets the
- #! correct register state
- gensym [
- [
- copy-phantoms
- ##prologue
- [ emit-nodes ] with-node-iterator
- ##epilogue
- ##return
- ] with-cfg-builder
- ] keep ;
-
-: dispatch-branches ( node -- )
- children>> [
- current-word get dispatch-branch
- ##dispatch-label
- ] each ;
-
-: emit-dispatch ( node -- )
- phantom-pop int-regs next-vreg
- [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
- dispatch-branches init-phantoms ;
-
-M: #dispatch emit-node
- tail-call? [
- emit-dispatch iterate-next
- ] [
- current-word get gensym [
- [
- begin-word
- emit-dispatch
- ] with-cfg-builder
- ] keep emit-call
- ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
- +intrinsics+ set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
- 2array 1array define-intrinsics ;
-
-: define-if-intrinsics ( word intrinsics -- )
- [ template new swap >>input ] assoc-map
- +if-intrinsics+ set-word-prop ;
-
-: define-if-intrinsic ( word quot inputs -- )
- 2array 1array define-if-intrinsics ;
-
-: find-intrinsic ( #call -- pair/f )
- word>> +intrinsics+ word-prop find-template ;
-
-: find-boolean-intrinsic ( #call -- pair/f )
- word>> +if-intrinsics+ word-prop find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
- node@ {
- { [ dup length 2 < ] [ 2drop f ] }
- { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
- [ 2drop f ]
- } cond ;
-
-: do-if-intrinsic ( pair -- next )
- [ ##if-intrinsic ] apply-template skip-next emit-if
- iterate-next ;
-
-: do-boolean-intrinsic ( pair -- next )
- [ ##if-intrinsic ] apply-template
- { t f } [
- <constant> phantom-push finalize-phantoms
- ] emit-branches
- iterate-next ;
-
-: do-intrinsic ( pair -- next )
- [ ##intrinsic ] apply-template iterate-next ;
-
-: setup-value-classes ( #call -- )
- node-input-infos [ class>> ] map set-value-classes ;
-
-{
- (tuple) (array) (byte-array)
- (complex) (ratio) (wrapper)
- (write-barrier)
-} [ t "intrinsic" set-word-prop ] each
-
-: allot-size ( -- n )
- 1 phantom-datastack get phantom-input first value>> ;
-
-:: emit-allot ( size type tag -- )
- int-regs next-vreg
- dup fresh-object
- dup size type tag int-regs next-vreg ##allot
- type tagged boa phantom-push ;
-
-: emit-write-barrier ( -- )
- phantom-pop dup >vreg fresh-object? [ drop ] [
- int-regs next-vreg ##write-barrier
- ] if ;
-
-: emit-intrinsic ( word -- next )
- {
- { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
- { \ (array) [ allot-size 2 cells + array object emit-allot ] }
- { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
- { \ (complex) [ 3 cells complex complex emit-allot ] }
- { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
- { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
- { \ (write-barrier) [ emit-write-barrier ] }
- } case
- iterate-next ;
-
-M: #call emit-node
- dup setup-value-classes
- dup find-if-intrinsic [ do-if-intrinsic ] [
- dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
- dup find-intrinsic [ do-intrinsic ] [
- word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ emit-call ] if
- ] ?if
- ] ?if
- ] ?if ;
-
-! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
-
-! #push
-M: #push emit-node
- literal>> <constant> phantom-push iterate-next ;
-
-! #shuffle
-M: #shuffle emit-node
- shuffle-effect phantom-shuffle iterate-next ;
-
-M: #>r emit-node
- [ in-d>> length ] [ out-r>> empty? ] bi
- [ phantom-drop ] [ phantom->r ] if
- iterate-next ;
-
-M: #r> emit-node
- [ in-r>> length ] [ out-d>> empty? ] bi
- [ phantom-rdrop ] [ phantom-r> ] if
- iterate-next ;
-
-! #return
-M: #return emit-node
- drop finalize-phantoms ##epilogue ##return f ;
-
-M: #return-recursive emit-node
- finalize-phantoms
- label>> id>> loops get key?
- [ ##epilogue ##return ] unless f ;
-
-! #terminate
-M: #terminate emit-node drop stop-iterating ;
-
-! FFI
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- {
- { [ dup c-struct? not ] [ drop 0 ] }
- { [ dup large-struct? not ] [ drop 2 cells ] }
- [ heap-size ]
- } cond ;
-
-: <alien-stack-frame> ( params -- stack-frame )
- stack-frame new
- swap
- [ return>> return-size >>return ]
- [ alien-parameters parameter-sizes drop >>params ] bi
- dup [ params>> ] [ return>> ] bi + >>size ;
-
-: alien-stack-frame ( node -- )
- params>> <alien-stack-frame> ##stack-frame ;
-
-: emit-alien-node ( node quot -- next )
- [ drop alien-stack-frame ]
- [ [ params>> ] dip call ] 2bi
- iterate-next ; inline
-
-M: #alien-invoke emit-node
- [ ##alien-invoke ] emit-alien-node ;
-
-M: #alien-indirect emit-node
- [ ##alien-indirect ] emit-alien-node ;
-
-M: #alien-callback emit-node
- params>> dup xt>> dup
- [
- init-phantoms
- [ ##alien-callback ] emit-alien-node drop
- ] with-cfg-builder
- iterate-next ;
-
-! No-op nodes
-M: #introduce emit-node drop iterate-next ;
-
-M: #copy emit-node drop iterate-next ;
-
-M: #enter-recursive emit-node drop iterate-next ;
-
-M: #phi emit-node drop iterate-next ;
+++ /dev/null
-Final stage of compilation generates machine code from dataflow IR
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sequences sets fry ;
-IN: compiler.cfg
-
-TUPLE: cfg entry word label ;
-
-C: <cfg> cfg
-
-! - "number" and "visited" is used by linearization.
-TUPLE: basic-block < identity-tuple
-visited
-number
-instructions
-successors ;
-
-: <basic-block> ( -- basic-block )
- basic-block new
- V{ } clone >>instructions
- V{ } clone >>successors ;
-
-TUPLE: mr instructions word label ;
-
-: <mr> ( instructions word label -- mr )
- mr new
- swap >>label
- swap >>word
- swap >>instructions ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
-accessors prettyprint prettyprint.config
-compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.linearization ;
-IN: compiler.cfg.debugger
-
-GENERIC: test-cfg ( quot -- cfgs )
-
-M: callable test-cfg
- build-tree optimize-tree gensym build-cfg ;
-
-M: word test-cfg
- [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
-
-: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
-
-: mr. ( mrs -- )
- [
- boa-tuples? on
- "=== word: " write
- dup word>> pprint
- ", label: " write
- dup label>> pprint nl nl
- instructions>> .
- nl
- ] each ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences namespaces
-math compiler.cfg.registers compiler.cfg.instructions.syntax ;
-IN: compiler.cfg.instructions
-
-! Virtual CPU instructions, used by CFG and machine IRs
-
-TUPLE: ##cond-branch < insn src ;
-TUPLE: ##unary < insn dst src ;
-TUPLE: ##nullary < insn dst ;
-
-! Stack operations
-INSN: ##load-literal < ##nullary obj ;
-INSN: ##peek < ##nullary loc ;
-INSN: ##replace src loc ;
-INSN: ##inc-d n ;
-INSN: ##inc-r n ;
-
-! Subroutine calls
-TUPLE: stack-frame
-{ size integer }
-{ params integer }
-{ return integer }
-{ total-size integer } ;
-
-INSN: ##stack-frame stack-frame ;
- : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
-INSN: ##call word ;
-INSN: ##jump word ;
-INSN: ##return ;
-
-INSN: ##intrinsic quot defs-vregs uses-vregs ;
-
-! Jump tables
-INSN: ##dispatch-label label ;
-INSN: ##dispatch src temp ;
-
-! Boxing and unboxing
-INSN: ##copy < ##unary ;
-INSN: ##copy-float < ##unary ;
-INSN: ##unbox-float < ##unary ;
-INSN: ##unbox-f < ##unary ;
-INSN: ##unbox-alien < ##unary ;
-INSN: ##unbox-byte-array < ##unary ;
-INSN: ##unbox-any-c-ptr < ##unary ;
-INSN: ##box-float < ##unary temp ;
-INSN: ##box-alien < ##unary temp ;
-
-! Memory allocation
-INSN: ##allot < ##nullary size type tag temp ;
-INSN: ##write-barrier src temp ;
-INSN: ##gc ;
-
-! FFI
-INSN: ##alien-invoke params ;
-INSN: ##alien-indirect params ;
-INSN: ##alien-callback params ;
-
-GENERIC: defs-vregs ( insn -- seq )
-GENERIC: uses-vregs ( insn -- seq )
-
-M: ##nullary defs-vregs dst>> >vreg 1array ;
-M: ##unary defs-vregs dst>> >vreg 1array ;
-M: ##write-barrier defs-vregs temp>> >vreg 1array ;
-
-: allot-defs-vregs ( insn -- seq )
- [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
-
-M: ##box-float defs-vregs allot-defs-vregs ;
-M: ##box-alien defs-vregs allot-defs-vregs ;
-M: ##allot defs-vregs allot-defs-vregs ;
-M: ##dispatch defs-vregs temp>> >vreg 1array ;
-M: insn defs-vregs drop f ;
-
-M: ##replace uses-vregs src>> >vreg 1array ;
-M: ##unary uses-vregs src>> >vreg 1array ;
-M: ##write-barrier uses-vregs src>> >vreg 1array ;
-M: ##dispatch uses-vregs src>> >vreg 1array ;
-M: insn uses-vregs drop f ;
-
-: intrinsic-vregs ( assoc -- seq' )
- [ nip >vreg ] { } assoc>map sift ;
-
-: intrinsic-defs-vregs ( insn -- seq )
- defs-vregs>> intrinsic-vregs ;
-
-: intrinsic-uses-vregs ( insn -- seq )
- uses-vregs>> intrinsic-vregs ;
-
-M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
-
-! Instructions used by CFG IR only.
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-INSN: ##branch-f < ##cond-branch ;
-INSN: ##branch-t < ##cond-branch ;
-INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
-
-M: ##cond-branch uses-vregs src>> >vreg 1array ;
-
-M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
-
-! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
-
-INSN: _label id ;
-
-TUPLE: _cond-branch < insn src label ;
-
-INSN: _branch label ;
-INSN: _branch-f < _cond-branch ;
-INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
-
-M: _cond-branch uses-vregs src>> >vreg 1array ;
-
-M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
-
-INSN: _spill-integer src n ;
-INSN: _reload-integer dst n ;
-
-INSN: _spill-float src n ;
-INSN: _reload-float dst n ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser ;
-IN: compiler.cfg.instructions.syntax
-
-TUPLE: insn ;
-
-: INSN:
- parse-tuple-definition "regs" suffix
- [ dup tuple eq? [ drop insn ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop dup '[ f _ boa , ] define-inline ]
- 3tri ; parsing
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.cfg.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get peek ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
- over empty? [
- 2drop
- ] [
- [ swap >node call node> drop ] keep iterate-nodes
- ] if ; inline recursive
-
-: with-node-iterator ( quot -- )
- >r V{ } clone node-stack r> with-variable ; inline
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
- [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
- [ t ] [
- [
- first
- [ #return? ]
- [ #return-recursive? ]
- [ #terminate? ] tri or or
- ] [ tail-phi? ] bi or
- ] if-empty ;
-
-: tail-call? ( -- ? )
- node-stack get [
- rest-slice
- [ t ] [
- [ (tail-call?) ]
- [ first #terminate? not ]
- bi and
- ] if-empty
- ] all? ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps
-compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals
-compiler.backend ;
-IN: compiler.cfg.linear-scan.allocation
-
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
-
-: free-registers-for ( vreg -- seq )
- reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
- [ reg>> ] [ vreg>> ] bi free-registers-for push ;
-
-! Vector of active live intervals
-SYMBOL: active-intervals
-
-: add-active ( live-interval -- )
- active-intervals get push ;
-
-: delete-active ( live-interval -- )
- active-intervals get delete ;
-
-: expire-old-intervals ( n -- )
- active-intervals get
- swap '[ end>> _ < ] partition
- active-intervals set
- [ deallocate-register ] each ;
-
-: expire-old-uses ( n -- )
- active-intervals get
- swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
-
-: update-state ( live-interval -- )
- start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
-: add-unhandled ( live-interval -- )
- [ check-progress ]
- [ dup start>> unhandled-intervals get heap-push ]
- bi ;
-
-: init-unhandled ( live-intervals -- )
- [ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
-
-: assign-free-register ( live-interval registers -- )
- #! If the live interval does not have any uses, it means it
- #! will be spilled immediately, so it still needs a register
- #! to compute the new value, but we don't add the interval
- #! to the active set and we don't remove the register from
- #! the free list.
- over uses>> empty?
- [ peek >>reg drop ] [ pop >>reg add-active ] if ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
- spill-counts get [ dup 1+ ] change-at ;
-
-: interval-to-spill ( -- live-interval )
- #! We spill the interval with the most distant use location.
- active-intervals get unclip-slice [
- [ [ uses>> peek ] bi@ > ] most
- ] reduce ;
-
-: check-split ( live-interval -- )
- [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
-
-: split-interval ( live-interval -- before after )
- #! Split the live interval at the location of its first use.
- #! 'Before' now starts and ends on the same instruction.
- [ check-split ]
- [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
- [ clone f >>reg dup uses>> peek >>start ]
- tri ;
-
-: record-split ( live-interval before after -- )
- [ >>split-before ] [ >>split-after ] bi* drop ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>> [ next-spill-location ] unless*
- tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
-
-: split-and-spill ( live-interval -- before after )
- dup split-interval [ record-split ] [ assign-spill ] 2bi ;
-
-: reuse-register ( new existing -- )
- reg>> >>reg
- dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ reuse-register ]
- [ delete-active ]
- [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
- over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
-
-: assign-blocked-register ( live-interval -- )
- interval-to-spill
- 2dup spill-existing?
- [ spill-existing ] [ spill-new ] if ;
-
-: assign-register ( live-interval -- )
- dup vreg>> free-registers-for [
- assign-blocked-register
- ] [
- assign-free-register
- ] if-empty ;
-
-! Main loop
-: init-allocator ( registers -- )
- V{ } clone active-intervals set
- <min-heap> unhandled-intervals set
- [ reverse >vector ] assoc-map free-registers set
- H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
- -1 progress set ;
-
-: handle-interval ( live-interval -- )
- [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
-
-: (allocate-registers) ( -- )
- unhandled-intervals get [ handle-interval ] slurp-heap ;
-
-: allocate-registers ( live-intervals machine-registers -- live-intervals )
- #! This modifies the input live-intervals.
- init-allocator
- dup init-unhandled
- (allocate-registers) ;
+++ /dev/null
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-\ assign-registers must-infer
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.linear-scan.live-intervals ;
-IN: compiler.cfg.linear-scan.assignment
-
-! A vector of live intervals. There is linear searching involved
-! 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
-
-: add-active ( live-interval -- )
- active-intervals get push ;
-
-: lookup-register ( vreg -- reg )
- active-intervals get [ vreg>> = ] with find nip reg>> ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-: add-unhandled ( live-interval -- )
- dup split-before>> [
- [ split-before>> ] [ split-after>> ] bi
- [ add-unhandled ] bi@
- ] [
- dup start>> unhandled-intervals get heap-push
- ] if ;
-
-: init-unhandled ( live-intervals -- )
- [ add-unhandled ] each ;
-
-: insert-spill ( live-interval -- )
- [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
- over [
- {
- { int-regs [ _spill-integer ] }
- { double-float-regs [ _spill-float ] }
- } case
- ] [ 3drop ] if ;
-
-: expire-old-intervals ( n -- )
- active-intervals get
- swap '[ end>> _ = ] partition
- active-intervals set
- [ insert-spill ] each ;
-
-: insert-reload ( live-interval -- )
- [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
- over [
- {
- { int-regs [ _reload-integer ] }
- { double-float-regs [ _reload-float ] }
- } case
- ] [ 3drop ] if ;
-
-: activate-new-intervals ( n -- )
- #! Any live intervals which start on the current instruction
- #! are added to the active set.
- unhandled-intervals get dup heap-empty? [ 2drop ] [
- 2dup heap-peek drop start>> = [
- heap-pop drop [ add-active ] [ insert-reload ] bi
- activate-new-intervals
- ] [ 2drop ] if
- ] if ;
-
-: (assign-registers) ( insn -- )
- dup
- [ defs-vregs ] [ uses-vregs ] bi append
- active-intervals get swap '[ vreg>> _ member? ] filter
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
- >>regs drop ;
-
-: init-assignment ( live-intervals -- )
- V{ } clone active-intervals set
- <min-heap> unhandled-intervals set
- init-unhandled ;
-
-: assign-registers ( insns live-intervals -- insns' )
- [
- init-assignment
- [
- [ activate-new-intervals ]
- [ drop [ (assign-registers) ] [ , ] bi ]
- [ expire-old-intervals ]
- tri
- ] each-index
- ] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences sets arrays
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation ;
-IN: compiler.cfg.linear-scan.debugger
-
-: check-assigned ( live-intervals -- )
- [
- reg>>
- [ "Not all intervals have registers" throw ] unless
- ] each ;
-
-: split-children ( live-interval -- seq )
- dup split-before>> [
- [ split-before>> ] [ split-after>> ] bi
- [ split-children ] bi@
- append
- ] [ 1array ] if ;
-
-: check-linear-scan ( live-intervals machine-registers -- )
- [ [ clone ] map ] dip allocate-registers
- [ split-children ] map concat check-assigned ;
+++ /dev/null
-IN: compiler.cfg.linear-scan.tests
-USING: tools.test random sorting sequences sets hashtables assocs
-kernel fry arrays splitting namespaces math accessors vectors
-math.order
-compiler.cfg.registers
-compiler.cfg.linear-scan
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.debugger ;
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[ ] [
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] unit-test
-
-[
- {
- T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
- T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
- }
- H{ { f { "A" } } }
- check-linear-scan
-] must-fail
-
-SYMBOL: available
-
-SYMBOL: taken
-
-SYMBOL: max-registers
-
-SYMBOL: max-insns
-
-SYMBOL: max-uses
-
-: not-taken ( -- n )
- available get keys dup empty? [ "Oops" throw ] when
- random
- dup taken get nth 1 + max-registers get = [
- dup available get delete-at
- ] [
- dup taken get [ 1 + ] change-nth
- ] if ;
-
-: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
- [
- max-insns set
- max-registers set
- max-uses set
- max-insns get [ 0 ] replicate taken set
- max-insns get [ dup ] H{ } map>assoc available set
- [
- live-interval new
- swap f swap vreg boa >>vreg
- max-uses get random 2 max [ not-taken ] replicate natural-sort
- unclip [ >vector >>uses ] [ >>start ] bi*
- dup uses>> first >>end
- ] map
- ] with-scope ;
-
-: random-test ( num-intervals max-uses max-registers max-insns -- )
- over >r random-live-intervals r> f associate check-linear-scan ;
-
-[ ] [ 30 2 1 60 random-test ] unit-test
-[ ] [ 60 2 2 60 random-test ] unit-test
-[ ] [ 80 2 3 200 random-test ] unit-test
-[ ] [ 70 2 5 30 random-test ] unit-test
-[ ] [ 60 2 6 30 random-test ] unit-test
-[ ] [ 1 2 10 10 random-test ] unit-test
-
-[ ] [ 10 4 2 60 random-test ] unit-test
-[ ] [ 10 20 2 400 random-test ] unit-test
-[ ] [ 10 20 4 300 random-test ] unit-test
-
-USING: math.private compiler.cfg.debugger ;
-
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces
-compiler.backend
-compiler.cfg
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation
-compiler.cfg.linear-scan.assignment ;
-IN: compiler.cfg.linear-scan
-
-! References:
-
-! Linear Scan Register Allocation
-! by Massimiliano Poletto and Vivek Sarkar
-! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
-
-! Linear Scan Register Allocation for the Java HotSpot Client Compiler
-! by Christian Wimmer
-! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
-
-! Quality and Speed in Linear-scan Register Allocation
-! by Omri Traub, Glenn Holloway, Michael D. Smith
-! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-
-: linear-scan ( mr -- mr' )
- [
- [
- dup compute-live-intervals
- machine-registers allocate-registers
- assign-registers
- ] change-instructions
- spill-counts get >>spill-counts
- ] with-scope ;
+++ /dev/null
-! Copyright (C) 2008 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 ;
-IN: compiler.cfg.linear-scan.live-intervals
-
-TUPLE: live-interval < identity-tuple
-vreg
-reg spill-to reload-from split-before split-after
-start end uses ;
-
-: <live-interval> ( start vreg -- live-interval )
- live-interval new
- swap >>vreg
- swap >>start
- V{ } clone >>uses ;
-
-M: live-interval hashcode*
- nip [ start>> ] [ end>> 1000 * ] bi + ;
-
-M: live-interval clone
- call-next-method [ clone ] change-uses ;
-
-! Mapping from vreg to live-interval
-SYMBOL: live-intervals
-
-: add-use ( n vreg live-intervals -- )
- at [ (>>end) ] [ uses>> push ] 2bi ;
-
-: new-live-interval ( n vreg live-intervals -- )
- 2dup key? [ "Multiple defs" throw ] when
- [ [ <live-interval> ] keep ] dip set-at ;
-
-: compute-live-intervals* ( insn n -- )
- live-intervals get
- [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
- [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
- 3bi ;
-
-: finalize-live-intervals ( assoc -- seq' )
- #! Reverse uses lists so that we can pop values off.
- values dup [ uses>> reverse-here ] each ;
-
-: compute-live-intervals ( instructions -- live-intervals )
- H{ } clone [
- live-intervals set
- [ compute-live-intervals* ] each-index
- ] keep finalize-live-intervals ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators
-compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.instructions
-compiler.cfg.instructions.syntax ;
-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
-
-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>> 1+ ] [ number>> ] bi* = ; inline
-
-: branch-to-return? ( successor -- ? )
- #! A branch to a block containing just a return is cloned.
- instructions>> dup length 2 = [
- [ first ##epilogue? ] [ second ##return? ] bi and
- ] [ drop f ] if ;
-
-: emit-branch ( basic-block successor -- )
- {
- { [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-return? ] [ nip linearize-insns ] }
- [ nip number>> _branch ]
- } cond ;
-
-M: ##branch linearize-insn
- drop dup successors>> first emit-branch ;
-
-: conditional ( basic-block -- basic-block successor1 label2 )
- dup successors>> first2 swap number>> ; inline
-
-: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
- [ conditional ] [ src>> ] bi* swap ; inline
-
-M: ##branch-f linearize-insn
- boolean-conditional _branch-f emit-branch ;
-
-M: ##branch-t linearize-insn
- boolean-conditional _branch-t emit-branch ;
-
-: >intrinsic< ( insn -- quot defs uses )
- [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
-
-M: ##if-intrinsic linearize-insn
- [ conditional ] [ >intrinsic< ] bi*
- _if-intrinsic emit-branch ;
-
-: linearize-basic-block ( bb -- )
- [ number>> _label ] [ linearize-insns ] bi ;
-
-: 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> ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel alien classes ;
-IN: compiler.cfg.registers
-
-! Virtual CPU registers, used by CFG and machine IRs
-
-MIXIN: value
-
-GENERIC: >vreg ( obj -- vreg )
-GENERIC: set-value-class ( class obj -- )
-GENERIC: value-class* ( operand -- class )
-
-: value-class ( operand -- class ) value-class* object or ;
-
-M: value >vreg drop f ;
-M: value set-value-class 2drop ;
-M: value value-class* drop f ;
-
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
-! Virtual registers
-TUPLE: vreg reg-class n ;
-SYMBOL: vreg-counter
-: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
-
-M: vreg >vreg ;
-
-INSTANCE: vreg value
-
-! Stack locations
-TUPLE: loc n class ;
-
-! A data stack location.
-TUPLE: ds-loc < loc ;
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-TUPLE: rs-loc < loc ;
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-
-INSTANCE: loc value
-
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-C: <cached> cached
-
-M: cached set-value-class vreg>> set-value-class ;
-M: cached value-class* vreg>> value-class* ;
-M: cached >vreg vreg>> >vreg ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-: <tagged> ( vreg -- tagged ) f tagged boa ;
-
-M: tagged set-value-class (>>class) ;
-M: tagged value-class* class>> ;
-M: tagged >vreg vreg>> ;
-
-INSTANCE: tagged value
-
-! Unboxed value
-TUPLE: unboxed vreg ;
-C: <unboxed> unboxed
-
-M: unboxed >vreg vreg>> ;
-
-INSTANCE: unboxed value
-
-! Unboxed alien pointer
-TUPLE: unboxed-alien < unboxed ;
-C: <unboxed-alien> unboxed-alien
-
-M: unboxed-alien value-class* drop simple-alien ;
-
-! Untagged byte array pointer
-TUPLE: unboxed-byte-array < unboxed ;
-C: <unboxed-byte-array> unboxed-byte-array
-
-M: unboxed-byte-array value-class* drop c-ptr ;
-
-! A register set to f
-TUPLE: unboxed-f < unboxed ;
-C: <unboxed-f> unboxed-f
-
-M: unboxed-f value-class* drop \ f ;
-
-! An alien, byte array or f
-TUPLE: unboxed-c-ptr < unboxed ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-
-M: unboxed-c-ptr value-class* drop c-ptr ;
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-
-M: constant value-class* value>> class ;
-
-INSTANCE: constant value
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make math sequences
-compiler.cfg.instructions ;
-IN: compiler.cfg.rpo
-
-: post-order-traversal ( basic-block -- )
- dup visited>> [ drop ] [
- t >>visited
- [ successors>> [ post-order-traversal ] each ] [ , ] bi
- ] if ;
-
-: post-order ( procedure -- blocks )
- [ post-order-traversal ] { } make ;
-
-: number-blocks ( blocks -- )
- [ >>number drop ] each-index ;
-
-: reverse-post-order ( procedure -- blocks )
- post-order <reversed> dup number-blocks ; inline
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math.order assocs kernel sequences
-make compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.registers ;
-IN: compiler.cfg.stack-frame
-
-SYMBOL: frame-required?
-
-SYMBOL: spill-counts
-
-: init-stack-frame-builder ( -- )
- frame-required? off
- T{ stack-frame } clone stack-frame set ;
-
-GENERIC: compute-stack-frame* ( insn -- )
-
-: max-stack-frame ( frame1 frame2 -- frame3 )
- {
- [ [ size>> ] bi@ max ]
- [ [ params>> ] bi@ max ]
- [ [ return>> ] bi@ max ]
- [ [ total-size>> ] bi@ max ]
- } cleave
- stack-frame boa ;
-
-M: ##stack-frame compute-stack-frame*
- frame-required? on
- stack-frame>> stack-frame [ max-stack-frame ] change ;
-
-M: _spill-integer compute-stack-frame*
- drop frame-required? on ;
-
-M: _spill-float compute-stack-frame*
- drop frame-required? on ;
-
-M: insn compute-stack-frame* drop ;
-
-: compute-stack-frame ( insns -- )
- [ compute-stack-frame* ] each ;
-
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##stack-frame insert-pro/epilogues* drop ;
-
-M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
- [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
- [
- init-stack-frame-builder
- [
- [ compute-stack-frame ]
- [ insert-pro/epilogues ]
- bi
- ] change-instructions
- ] with-scope ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math fry namespaces
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order compiler.backend
-compiler.cfg.instructions compiler.cfg.registers ;
-IN: compiler.cfg.stacks
-
-! Converting stack operations into register operations, while
-! doing a bit of optimization along the way.
-SYMBOL: known-tag
-
-! Value protocol
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-load) 1 ( value spec -- value )
-GENERIC# (eager-load) 1 ( value spec -- value )
-GENERIC: lazy-store ( dst src -- )
-GENERIC: minimal-ds-loc* ( min obj -- min )
-
-! This will be a multimethod soon
-DEFER: %move
-
-PRIVATE>
-
-! Default implementation
-M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
-M: value lazy-store 2drop ;
-
-M: vreg move-spec reg-class>> move-spec ;
-M: vreg value-class* reg-class>> value-class* ;
-
-M: int-regs move-spec drop f ;
-M: int-regs value-class* drop object ;
-
-M: float-regs move-spec drop float ;
-M: float-regs value-class* drop float ;
-
-M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc live-loc?
- over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-M: rs-loc live-loc?
- over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-M: loc value-class* class>> ;
-M: loc set-value-class (>>class) ;
-M: loc move-spec drop loc ;
-
-M: f move-spec drop loc ;
-M: f value-class* ;
-
-M: cached move-spec drop cached ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
-M: cached (eager-load) >r vreg>> r> (eager-load) ;
-M: cached lazy-store
- 2dup loc>> live-loc?
- [ "live-locs" get at %move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-
-M: tagged move-spec drop f ;
-
-M: unboxed-alien move-spec class ;
-
-M: unboxed-byte-array move-spec class ;
-
-M: unboxed-f move-spec class ;
-
-M: unboxed-c-ptr move-spec class ;
-
-M: constant move-spec class ;
-
-! Moving values between locations and registers
-: %move-bug ( -- * ) "Bug in generator.registers" throw ;
-
-: %unbox-c-ptr ( dst src -- )
- dup value-class {
- { [ dup \ f class<= ] [ drop ##unbox-f ] }
- { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
- { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
- [ drop ##unbox-any-c-ptr ]
- } cond ; inline
-
-: %move-via-temp ( dst src -- )
- #! For many transfers, such as loc to unboxed-alien, we
- #! don't have an intrinsic, so we transfer the source to
- #! temp then temp to the destination.
- int-regs next-vreg [ over %move value-class ] keep
- tagged new
- swap >>vreg
- swap >>class
- %move ;
-
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-: fresh-object ( vreg/t -- ) fresh-objects get push ;
-
-: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
-
-: %move ( dst src -- )
- 2dup [ move-spec ] bi@ 2array {
- { { f f } [ ##copy ] }
- { { unboxed-alien unboxed-alien } [ ##copy ] }
- { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
- { { unboxed-f unboxed-f } [ ##copy ] }
- { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
- { { float float } [ ##copy-float ] }
-
- { { f unboxed-c-ptr } [ %move-bug ] }
- { { f unboxed-byte-array } [ %move-bug ] }
-
- { { f constant } [ value>> ##load-literal ] }
-
- { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
- { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
- { { f loc } [ ##peek ] }
-
- { { float f } [ ##unbox-float ] }
- { { unboxed-alien f } [ ##unbox-alien ] }
- { { unboxed-byte-array f } [ ##unbox-byte-array ] }
- { { unboxed-f f } [ ##unbox-f ] }
- { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
- { { loc f } [ swap ##replace ] }
-
- [ drop %move-via-temp ]
- } case ;
-
-! A compile-time stack
-TUPLE: phantom-stack height stack ;
-
-M: phantom-stack clone
- call-next-method [ clone ] change-stack ;
-
-GENERIC: finalize-height ( stack -- )
-
-: new-phantom-stack ( class -- stack )
- >r 0 V{ } clone r> boa ; inline
-
-: (loc) ( m stack -- n )
- #! Utility for methods on <loc>
- height>> - ;
-
-: (finalize-height) ( stack word -- )
- #! We consolidate multiple stack height changes until the
- #! last moment, and we emit the final height changing
- #! instruction here.
- '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
-
-GENERIC: <loc> ( n stack -- loc )
-
-TUPLE: phantom-datastack < phantom-stack ;
-
-: <phantom-datastack> ( -- stack )
- phantom-datastack new-phantom-stack ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
- \ ##inc-d (finalize-height) ;
-
-TUPLE: phantom-retainstack < phantom-stack ;
-
-: <phantom-retainstack> ( -- stack )
- phantom-retainstack new-phantom-stack ;
-
-M: phantom-retainstack <loc> (loc) <rs-loc> ;
-
-M: phantom-retainstack finalize-height
- \ ##inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
- #! A sequence of n ds-locs or rs-locs indexing the stack.
- >r <reversed> r> '[ _ <loc> ] map ;
-
-: phantom-locs* ( phantom -- locs )
- [ stack>> length ] keep phantom-locs ;
-
-: phantoms ( -- phantom phantom )
- phantom-datastack get phantom-retainstack get ;
-
-: (each-loc) ( phantom quot -- )
- >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
-
-: each-loc ( quot -- )
- phantoms 2array swap '[ _ (each-loc) ] each ; inline
-
-: adjust-phantom ( n phantom -- )
- swap '[ _ + ] change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
- swap '[ _ cut* swap ] change-stack drop ;
-
-: phantom-append ( seq stack -- )
- over length over adjust-phantom stack>> push-all ;
-
-: add-locs ( n phantom -- )
- 2dup stack>> length <= [
- 2drop
- ] [
- [ phantom-locs ] keep
- [ stack>> length head-slice* ] keep
- [ append >vector ] change-stack drop
- ] if ;
-
-: phantom-input ( n phantom -- seq )
- 2dup add-locs
- 2dup cut-phantom
- >r >r neg r> adjust-phantom r> ;
-
-: each-phantom ( quot -- ) phantoms rot bi@ ; inline
-
-: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-
-: (live-locs) ( phantom -- seq )
- #! Discard locs which haven't moved
- [ phantom-locs* ] [ stack>> ] bi zip
- [ live-loc? ] assoc-filter
- values ;
-
-: live-locs ( -- seq )
- [ (live-locs) ] each-phantom append prune ;
-
-: reg-spec>class ( spec -- class )
- float eq? double-float-regs int-regs ? ;
-
-: alloc-vreg ( spec -- reg )
- [ reg-spec>class next-vreg ] keep {
- { f [ <tagged> ] }
- { unboxed-alien [ <unboxed-alien> ] }
- { unboxed-byte-array [ <unboxed-byte-array> ] }
- { unboxed-f [ <unboxed-f> ] }
- { unboxed-c-ptr [ <unboxed-c-ptr> ] }
- [ drop ]
- } case ;
-
-: compatible? ( value spec -- ? )
- >r move-spec r> {
- { [ 2dup = ] [ t ] }
- { [ dup unboxed-c-ptr eq? ] [
- over { unboxed-byte-array unboxed-alien } member?
- ] }
- [ f ]
- } cond 2nip ;
-
-: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap value-class
- over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
- {
- { [ dup { small-slot small-tagged } memq? ] [ drop ] }
- { [ 2dup compatible? ] [ drop ] }
- [ (eager-load) ]
- } cond ;
-
-M: value (eager-load) ( value spec -- vreg )
- [ alloc-vreg-for ] [ drop ] 2bi
- [ %move ] [ drop ] 2bi ;
-
-M: loc lazy-store
- 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
-
-: finalize-locs ( -- )
- #! Perform any deferred stack shuffling.
- live-locs [ dup f (lazy-load) ] H{ } map>assoc
- dup assoc-empty? [ drop ] [
- "live-locs" set [ lazy-store ] each-loc
- ] if ;
-
-: finalize-vregs ( -- )
- #! Store any vregs to their final stack locations.
- [
- dup loc? over cached? or [ 2drop ] [ %move ] if
- ] each-loc ;
-
-: clear-phantoms ( -- )
- [ stack>> delete-all ] each-phantom ;
-
-: finalize-contents ( -- )
- finalize-locs finalize-vregs clear-phantoms ;
-
-! Loading stacks to vregs
-: vreg-substitution ( value vreg -- pair )
- dupd <cached> 2array ;
-
-: substitute-vreg? ( old new -- ? )
- #! We don't substitute locs for float or alien vregs,
- #! since in those cases the boxing overhead might kill us.
- vreg>> tagged? >r loc? r> and ;
-
-: substitute-vregs ( values vregs -- )
- [ vreg-substitution ] 2map
- [ substitute-vreg? ] assoc-filter >hashtable
- '[ stack>> _ substitute-here ] each-phantom ;
-
-: set-value-classes ( classes -- )
- phantom-datastack get
- over length over add-locs
- stack>> [
- [ value-class class-and ] keep set-value-class
- ] 2reverse-each ;
-
-: finalize-phantoms ( -- )
- #! Commit all deferred stacking shuffling, and ensure the
- #! in-memory data and retain stacks are up to date with
- #! respect to the compiler's current picture.
- finalize-contents
- finalize-heights
- fresh-objects get [
- empty? [ ##simple-stack-frame ##gc ] unless
- ] [ delete-all ] bi ;
-
-: init-phantoms ( -- )
- V{ } clone fresh-objects set
- <phantom-datastack> phantom-datastack set
- <phantom-retainstack> phantom-retainstack set ;
-
-: copy-phantoms ( -- )
- fresh-objects [ clone ] change
- phantom-datastack [ clone ] change
- phantom-retainstack [ clone ] change ;
-
-: phantom-push ( obj -- )
- 1 phantom-datastack get adjust-phantom
- phantom-datastack get stack>> push ;
-
-: phantom-shuffle ( shuffle -- )
- [ in>> length phantom-datastack get phantom-input ] keep
- shuffle phantom-datastack get phantom-append ;
-
-: phantom->r ( n -- )
- phantom-datastack get phantom-input
- phantom-retainstack get phantom-append ;
-
-: phantom-r> ( n -- )
- phantom-retainstack get phantom-input
- phantom-datastack get phantom-append ;
-
-: phantom-drop ( n -- )
- phantom-datastack get phantom-input drop ;
-
-: phantom-rdrop ( n -- )
- phantom-retainstack get phantom-input drop ;
-
-: phantom-pop ( -- vreg )
- 1 phantom-datastack get phantom-input dup first f (lazy-load)
- [ 1array substitute-vregs ] keep ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.backend
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
-IN: compiler.cfg.templates
-
-TUPLE: template input output scratch clobber gc ;
-
-: phantom&spec ( phantom specs -- phantom' specs' )
- >r stack>> r>
- [ length f pad-left ] keep
- [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
- >r phantom&spec r> 2all? ; inline
-
-: live-vregs ( -- seq )
- [ stack>> [ >vreg ] map sift ] each-phantom append ;
-
-: clobbered ( template -- seq )
- [ output>> ] [ clobber>> ] bi append ;
-
-: clobbered? ( value name -- ? )
- \ clobbered get member? [
- >vreg \ live-vregs get member?
- ] [ drop f ] if ;
-
-: lazy-load ( specs -- seq )
- [ length phantom-datastack get phantom-input ] keep
- [
- 2dup second clobbered?
- [ first (eager-load) ] [ first (lazy-load) ] if
- ] 2map ;
-
-: load-inputs ( template -- assoc )
- [
- live-vregs \ live-vregs set
- dup clobbered \ clobbered set
- input>> [ values ] [ lazy-load ] bi zip
- ] with-scope ;
-
-: alloc-scratch ( template -- assoc )
- scratch>> [ swap alloc-vreg ] assoc-map ;
-
-: do-template-inputs ( template -- defs uses )
- #! Load input values into registers and allocates scratch
- #! registers.
- [ alloc-scratch ] [ load-inputs ] bi ;
-
-: do-template-outputs ( template defs uses -- )
- [ output>> ] 2dip assoc-union '[ _ at ] map
- phantom-datastack get phantom-append ;
-
-: apply-template ( pair quot -- vregs )
- [
- first2
- dup gc>> [ t fresh-object ] when
- dup do-template-inputs
- [ do-template-outputs ] 2keep
- ] dip call ; inline
-
-: value-matches? ( value spec -- ? )
- #! If the spec is a quotation and the value is a literal
- #! fixnum, see if the quotation yields true when applied
- #! to the fixnum. Otherwise, the values don't match. If the
- #! spec is not a quotation, its a reg-class, in which case
- #! the value is always good.
- {
- { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
- { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
- [ 2drop t ]
- } cond ;
-
-: class-matches? ( actual expected -- ? )
- {
- { f [ drop t ] }
- { known-tag [ dup [ class-tag >boolean ] when ] }
- [ class<= ]
- } case ;
-
-: spec-matches? ( value spec -- ? )
- 2dup first value-matches?
- >r >r value-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( template -- ? )
- input>> phantom-datastack get swap
- [ spec-matches? ] phantom&spec-agree? ;
-
-: find-template ( templates -- pair/f )
- #! Pair has shape { quot assoc }
- [ second template-matches? ] find nip ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.parser sequences accessors
-kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types alien.structs
-alien.strings sets threads libc continuations.private
-compiler.errors
-compiler.alien
-compiler.backend
-compiler.codegen.fixup
-compiler.cfg
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.cfg.builder ;
-IN: compiler.codegen
-
-GENERIC: generate-insn ( insn -- )
-
-GENERIC: v>operand ( obj -- operand )
-
-SYMBOL: registers
-
-M: constant v>operand
- value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-
-M: value v>operand
- >vreg [ registers get at ] [ "Bad value" throw ] if* ;
-
-: generate-insns ( insns -- code )
- [
- [
- dup regs>> registers set
- generate-insn
- ] each
- ] { } make fixup ;
-
-TUPLE: asm label code calls ;
-
-SYMBOL: calls
-
-: add-call ( word -- )
- #! Compile this word later.
- calls get push ;
-
-SYMBOL: compiling-word
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-! Mapping _label IDs to label instances
-SYMBOL: labels
-
-: 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 f ? add-literal drop ;
-
-: generate ( mr -- asm )
- [
- [ label>> ]
- [ word>> init-generator ]
- [ instructions>> generate-insns ] tri
- calls get
- asm boa
- ] with-scope ;
-
-: lookup-label ( id -- label )
- labels get [ drop <label> ] cache ;
-
-M: _label generate-insn
- id>> lookup-label , ;
-
-M: _prologue generate-insn
- stack-frame>>
- [ stack-frame set ]
- [ dup size>> stack-frame-size >>total-size drop ]
- [ total-size>> %prologue ]
- tri ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: ##load-literal generate-insn
- [ obj>> ] [ dst>> v>operand ] bi load-literal ;
-
-M: ##peek generate-insn
- [ dst>> v>operand ] [ loc>> ] bi %peek ;
-
-M: ##replace generate-insn
- [ src>> ] [ loc>> ] bi %replace ;
-
-M: ##inc-d generate-insn n>> %inc-d ;
-
-M: ##inc-r generate-insn n>> %inc-r ;
-
-M: ##return generate-insn drop %return ;
-
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
-
-SYMBOL: operands
-
-: init-intrinsic ( insn -- )
- [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
-
-M: ##intrinsic generate-insn
- [ init-intrinsic ] [ quot>> call ] bi ;
-
-: (operand) ( name -- operand )
- operands get at* [ "Bad operand name" throw ] unless ;
-
-: operand ( name -- operand )
- (operand) v>operand ;
-
-: operand-class ( var -- class )
- (operand) value-class ;
-
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
-: unique-operands ( operands quot -- )
- >r [ operand ] map prune r> each ; inline
-
-M: _if-intrinsic generate-insn
- [ init-intrinsic ]
- [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-M: _branch-f generate-insn
- [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
-
-M: _branch-t generate-insn
- [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
-
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
-
-M: ##dispatch generate-insn drop %dispatch ;
-
-: dst/src ( insn -- dst src )
- [ dst>> v>operand ] [ src>> v>operand ] bi ;
-
-M: ##copy generate-insn dst/src %copy ;
-
-M: ##copy-float generate-insn dst/src %copy-float ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-
-M: ##unbox-f generate-insn dst/src %unbox-f ;
-
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
-
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
-
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
-
-M: ##box-float generate-insn dst/src %box-float ;
-
-M: ##box-alien generate-insn dst/src %box-alien ;
-
-M: ##allot generate-insn
- {
- [ dst>> v>operand ]
- [ size>> ]
- [ type>> ]
- [ tag>> ]
- [ temp>> v>operand ]
- } cleave
- %allot ;
-
-M: ##write-barrier generate-insn
- [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
-
-M: ##gc generate-insn drop %gc ;
-
-! #alien-invoke
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
- dup reg-class-variable inc
- fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
- dup call-next-method
- fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-GENERIC: reg-class-full? ( class -- ? )
-
-M: stack-params reg-class-full? drop t ;
-
-M: object reg-class-full?
- [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
- stack-params get
- >r reg-size stack-params +@ r>
- stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
- [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
- c-type-reg-class dup reg-class-full?
- [ spill-param ] [ fastcall-param ] if
- [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- seq )
- cell /i "void*" c-type <repetition> ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-
-M: struct-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
- stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
- #! Convert value type structs to consecutive void*s.
- [
- 0 [
- c-type
- [ parameter-align (flatten-int-type) % ] keep
- [ stack-size cell align + ] keep
- flatten-value-type %
- ] reduce drop
- ] { } make ;
-
-: each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
- >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
- { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
- #! In quot you can call alloc-parameter
- [ reset-freg-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
- #! Moves values from C stack to registers (if word is
- #! %load-param-reg) and registers to C stack (if word is
- #! %save-param-reg).
- >r
- alien-parameters
- flatten-value-types
- r> [ >r alloc-parameter r> execute ] curry each-parameter ;
- inline
-
-: unbox-parameters ( offset node -- )
- parameters>> [
- %prepare-unbox >r over + r> unbox-parameter
- ] reverse-each-parameter drop ;
-
-: prepare-box-struct ( node -- offset )
- #! Return offset on C stack where to store unboxed
- #! parameters. If the C function is returning a structure,
- #! the first parameter is an implicit target area pointer,
- #! so we need to use a different offset.
- return>> large-struct?
- [ %prepare-box-struct cell ] [ 0 ] if ;
-
-: objects>registers ( params -- )
- #! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to register on
- #! architectures where parameters are passed in registers.
- [
- [ prepare-box-struct ] keep
- [ unbox-parameters ] keep
- \ %load-param-reg move-parameters
- ] with-param-regs ;
-
-: box-return* ( node -- )
- return>> [ ] [ box-return ] if-void ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
- drop "Library not found" ;
-
-M: no-such-library compiler-error-type
- drop +linkage+ ;
-
-: no-such-library ( name -- )
- \ no-such-library boa
- compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
- drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
-
-: no-such-symbol ( name -- )
- \ no-such-symbol boa
- compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
- dup dll-valid? [
- dupd [ dlsym ] curry contains?
- [ drop ] [ no-such-symbol ] if
- ] [
- dll-path no-such-library drop
- ] if ;
-
-: stdcall-mangle ( symbol node -- symbol )
- "@"
- swap parameters>> parameter-sizes drop
- number>string 3append ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
- dup function>> dup pick stdcall-mangle 2array
- swap library>> library dup [ dll>> ] when
- 2dup check-dlsym ;
-
-M: ##alien-invoke generate-insn
- params>>
- ! Save registers for GC
- %prepare-alien-invoke
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call function
- dup alien-invoke-dlsym %alien-invoke
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
- params>>
- ! Save registers for GC
- %prepare-alien-invoke
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- ! Unbox parameters
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- ! Box return value
- dup %cleanup
- box-return* ;
-
-! ##alien-callback
-: box-parameters ( params -- )
- alien-parameters [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
- [
- dup \ %save-param-reg move-parameters
- "nest_stacks" f %alien-invoke
- box-parameters
- ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
- dup current-callback eq? [
- drop
- ] [
- yield wait-to-return
- ] if ;
-
-: do-callback ( quot token -- )
- init-catchstack
- dup 2 setenv
- slip
- wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
- return>> {
- { [ dup "void" = ] [ drop [ ] ] }
- { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- [ c-type c-type-unboxer-quot ]
- } cond ;
-
-: callback-prep-quot ( params -- quot )
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
- [
- [ callback-prep-quot ]
- [ quot>> ]
- [ callback-return-quot ] tri 3append ,
- [ callback-context new do-callback ] %
- ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( params -- n )
- {
- { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
- { [ dup return>> large-struct? ] [ drop 4 ] }
- [ drop 0 ]
- } cond ;
-
-: %callback-return ( params -- )
- #! All the extra book-keeping for %unwind is only for x86.
- #! On other platforms its an alias for %return.
- dup alien-return
- [ %unnest-stacks ] [ %callback-value ] if-void
- callback-unwind %unwind ;
-
-M: ##alien-callback generate-insn
- params>>
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays generic assocs hashtables io.binary
-kernel kernel.private math namespaces make sequences words
-quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private math.order accessors
-growable compiler.constants compiler.backend ;
-IN: compiler.codegen.fixup
-
-GENERIC: fixup* ( obj -- )
-
-: code-format 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
-
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
-
-TUPLE: label-fixup label class ;
-
-: label-fixup ( label class -- ) \ label-fixup boa , ;
-
-M: label-fixup fixup*
- dup class>> rc-absolute?
- [ "Absolute labels not supported" throw ] when
- [ label>> ] [ class>> ] bi compiled-offset 4 - rot
- 3array label-table get push ;
-
-TUPLE: rel-fixup arg class type ;
-
-: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-
-: push-4 ( value vector -- )
- [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
- swap set-alien-unsigned-4 ;
-
-M: rel-fixup fixup*
- [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
- [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
- [ relocation-table get push-4 ] bi@ ;
-
-M: integer fixup* , ;
-
-: adjoin* ( obj table -- n )
- 2dup swap [ eq? ] curry find drop
- [ 2nip ] [ dup length >r push r> ] if* ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- n ) literal-table get adjoin* ;
-
-: add-dlsym-literals ( symbol dll -- )
- >r string>symbol r> 2array literal-table get push-all ;
-
-: rel-dlsym ( name dll class -- )
- >r literal-table get length >r
- add-dlsym-literals
- r> r> rt-dlsym rel-fixup ;
-
-: rel-word ( word class -- )
- >r add-literal r> rt-xt rel-fixup ;
-
-: rel-primitive ( word class -- )
- >r def>> first r> rt-primitive rel-fixup ;
-
-: rel-literal ( literal class -- )
- >r add-literal r> rt-literal rel-fixup ;
-
-: rel-this ( class -- )
- 0 swap rt-label rel-fixup ;
-
-: rel-here ( class -- )
- 0 swap rt-here rel-fixup ;
-
-: init-fixup ( -- )
- BV{ } clone relocation-table set
- V{ } clone label-table set ;
-
-: resolve-labels ( labels -- labels' )
- [
- first3 offset>>
- [ "Unresolved label" throw ] unless*
- 3array
- ] map concat ;
-
-: fixup ( fixup-directives -- code )
- [
- init-fixup
- [ fixup* ] each
- literal-table get >array
- relocation-table get >byte-array
- label-table get resolve-labels
- ] { } make 4array ;
+++ /dev/null
-Support for generation of relocatable code
projects / factor.git / commitdiff