! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler kernel math namespaces make parser
-prettyprint prettyprint.sections quotations sequences strings
-words cocoa.runtime io macros memoize debugger fry
-io.encodings.ascii effects compiler.generator libc libc.private ;
+combinators compiler compiler.alien kernel math namespaces make
+parser prettyprint prettyprint.sections quotations sequences
+strings words cocoa.runtime io macros memoize debugger
+io.encodings.ascii effects libc libc.private parser lexer init
+core-foundation ;
IN: cocoa.messages
: make-sender ( method function -- quot )
--- /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
+cpu.architecture
+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
+SYMBOL: first-basic-block
+
+! 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 ;
+
+: 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
+ basic-block get first-basic-block set ;
+
+: (build-cfg) ( nodes word label -- )
+ [
+ begin-word
+ V{ } clone node-stack set
+ emit-nodes
+ ] 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
+ {
+ { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+ { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
+ { [ dup current-label get eq? ] [ drop first-basic-block get 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 ;
+
+: remember-loop ( label -- )
+ basic-block get swap loops get set-at ;
+
+: 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 )
+ gensym [
+ [
+ V{ } clone node-stack set
+ init-phantoms
+ ##prologue
+ emit-nodes
+ basic-block get [
+ ##epilogue
+ ##return
+ end-basic-block
+ ] when
+ ] 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-phantoms ##epilogue ] 2dip ##dispatch
+ dispatch-branches init-phantoms ;
+
+: <dispatch-block> ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
+
+M: #dispatch emit-node
+ tail-call? [
+ emit-dispatch stop-iterating
+ ] [
+ current-word get <dispatch-block> [
+ [
+ begin-word
+ emit-dispatch
+ ] with-cfg-builder
+ ] keep emit-call
+ ] if ;
+
+! #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 fresh-object? [ drop ] [
+ int-regs next-vreg
+ 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 2 cells + 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 stop-iterating ;
+
+M: #return-recursive emit-node
+ finalize-phantoms
+ label>> id>> loops get key?
+ [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+
+! #terminate
+M: #terminate emit-node
+ drop finalize-phantoms 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 ( params -- )
+ <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ finalize-phantoms
+ [ params>> ] dip [ drop alien-stack-frame ] [ 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
+ dup params>> xt>> dup
+ [
+ init-phantoms
+ ##prologue
+ dup [ ##alien-callback ] emit-alien-node drop
+ ##epilogue
+ params>> ##callback-return
+ ] 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
+compiler.cfg.stack-frame ;
+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 build-stack-frame ] 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 words
+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 vreg } ;
+TUPLE: ##unary < insn { dst vreg } { src vreg } ;
+TUPLE: ##nullary < insn { dst vreg } ;
+
+! Stack operations
+INSN: ##load-literal < ##nullary obj ;
+INSN: ##peek < ##nullary { loc loc } ;
+INSN: ##replace { src vreg } { loc loc } ;
+INSN: ##inc-d { n integer } ;
+INSN: ##inc-r { n integer } ;
+
+! 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 src temp ;
+INSN: ##dispatch-label label ;
+
+! 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 vreg } ;
+INSN: ##box-alien < ##unary { temp vreg } ;
+
+! Memory allocation
+INSN: ##allot < ##nullary size type tag { temp vreg } ;
+INSN: ##write-barrier { src vreg } card# table ;
+INSN: ##gc ;
+
+! FFI
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
+INSN: ##callback-return params ;
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+M: ##nullary defs-vregs dst>> 1array ;
+M: ##unary defs-vregs dst>> 1array ;
+M: ##write-barrier defs-vregs
+ [ card#>> ] [ table>> ] bi 2array ;
+
+: allot-defs-vregs ( insn -- seq )
+ [ dst>> ] [ temp>> ] 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>> 1array ;
+M: insn defs-vregs drop f ;
+
+M: ##replace uses-vregs src>> 1array ;
+M: ##unary uses-vregs src>> 1array ;
+M: ##write-barrier uses-vregs src>> 1array ;
+M: ##dispatch uses-vregs src>> 1array ;
+M: insn uses-vregs drop f ;
+
+: intrinsic-vregs ( assoc -- seq' )
+ values 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>> 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 vreg } 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>> 1array ;
+
+M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
+
+INSN: _spill-integer { src vreg } n ;
+INSN: _reload-integer { dst vreg } n ;
+
+INSN: _spill-float { src vreg } n ;
+INSN: _reload-float { dst vreg } 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
+
+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 cpu.architecture
+compiler.cfg.registers
+compiler.cfg.linear-scan.live-intervals ;
+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 ;
+
+: expired-interval? ( n interval -- ? )
+ [ end>> ] [ start>> ] bi or > ;
+
+: expire-old-intervals ( n -- )
+ active-intervals get
+ [ expired-interval? ] with partition
+ [ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
+
+: expire-old-uses ( n -- )
+ active-intervals get
+ swap '[
+ uses>> [
+ dup peek _ < [ pop* ] [ drop ] if
+ ] unless-empty
+ ] 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 -- )
+ pop >>reg add-active ;
+
+! 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
+ [ uses>> empty? not ] filter
+ 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.
+ USE: cpu.architecture ! XXX
+ over reload-from>>
+ [ int-regs 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 add-active ;
+
+: 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
+cpu.architecture
+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
+cpu.architecture
+compiler.cfg.instructions
+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
+
+[ f ] [
+ T{ ##allot
+ f
+ T{ vreg f int-regs 1 }
+ 40
+ array
+ object
+ T{ vreg f int-regs 2 }
+ f
+ } clone
+ 1array (linear-scan) first regs>> values all-equal?
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces
+cpu.architecture
+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) ( insns -- insns' )
+ dup compute-live-intervals
+ machine-registers allocate-registers assign-registers ;
+
+: linear-scan ( mr -- mr' )
+ [
+ [ (linear-scan) ] 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 ;
+
+! 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 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
+combinators 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 ]
+ } 2cleave
+ 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 cpu.architecture
+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.
+PREDICATE: small-slot < integer cells small-enough? ;
+
+PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
+
+! Value protocol
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC: lazy-store ( dst src -- )
+
+! This will be a multimethod soon
+DEFER: ##move
+
+PRIVATE>
+
+! Default implementation
+M: value live-loc? 2drop f ;
+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 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: 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 compiler.cfg.stacks" throw ;
+
+: ##unbox-c-ptr ( dst src -- )
+ dup value-class {
+ { [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
+ [ drop [ >vreg ] bi@ ##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 } [ [ >vreg ] bi@ ##copy ] }
+ { { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
+ { { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
+ { { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
+ { { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
+ { { float float } [ [ >vreg ] bi@ ##copy-float ] }
+
+ { { f unboxed-c-ptr } [ ##move-bug ] }
+ { { f unboxed-byte-array } [ ##move-bug ] }
+
+ { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
+
+ { { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
+ { { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
+ { { f loc } [ [ >vreg ] dip ##peek ] }
+
+ { { float f } [ [ >vreg ] bi@ ##unbox-float ] }
+ { { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
+ { { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
+ { { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
+ { { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
+ { { loc f } [ >vreg 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.
+ [ <reversed> ] dip '[ _ <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 ;
+
+: 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 ;
+
+: alloc-vreg-for ( value spec -- vreg )
+ alloc-vreg swap value-class
+ over tagged? [ >>class ] [ drop ] if ;
+
+: (eager-load) ( value spec -- vreg )
+ [ alloc-vreg-for ] [ drop ] 2bi
+ [ ##move ] [ drop >vreg ] 2bi ;
+
+: compatible? ( value spec -- ? )
+ >r move-spec r> {
+ { [ 2dup = ] [ t ] }
+ { [ dup unboxed-c-ptr eq? ] [
+ over { unboxed-byte-array unboxed-alien } member?
+ ] }
+ [ f ]
+ } cond 2nip ;
+
+: (lazy-load) ( value spec -- value )
+ {
+ { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
+ { [ 2dup compatible? ] [ drop >vreg ] }
+ [ (eager-load) ]
+ } cond ;
+
+: (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 ;
+
+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? [ 2drop ] [ ##move ] if ] each-loc ;
+
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
+
+: finalize-contents ( -- )
+ finalize-locs finalize-vregs clear-phantoms ;
+
+! Loading stacks to vregs
+: set-value-classes ( classes -- )
+ phantom-datastack get
+ over length over add-locs
+ stack>> [ 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 first f (lazy-load) ;
--- /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.cfg.instructions
+compiler.cfg.registers compiler.cfg.stacks ;
+IN: compiler.cfg.templates
+
+TUPLE: template input output scratch clobber gc ;
+
+: 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 >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
+
+: phantom&spec ( phantom specs -- phantom' specs' )
+ >r stack>> r>
+ [ length f pad-left ] keep
+ [ <reversed> ] bi@ ; 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 -- ? )
+ dup [ class<= ] [ 2drop t ] if ;
+
+: 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 phantom&spec
+ [ spec-matches? ] 2all? ;
+
+: 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 alien.arrays sets threads libc continuations.private
+cpu.architecture
+compiler.errors
+compiler.alien
+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
+ registers get at [ "Bad value" throw ] unless* ;
+
+: 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>> v>operand ] [ 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 ;
+
+: literal ( name -- value )
+ (operand) value>> ;
+
+: 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
+ [ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
+
+M: _branch-t generate-insn
+ [ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn
+ [ src>> v>operand ] [ temp>> v>operand ] bi %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 ;
+
+: dst/src/temp ( insn -- dst src temp )
+ [ dst/src ] [ temp>> v>operand ] bi ;
+
+M: ##box-float generate-insn dst/src/temp %box-float ;
+
+M: ##box-alien generate-insn dst/src/temp %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 ]
+ [ card#>> v>operand ]
+ [ table>> v>operand ]
+ tri %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 ;
+
+M: stack-params reg-size drop "void*" heap-size ;
+
+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 ;
+
+M: ##callback-return generate-insn
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ params>> %callback-return ;
+
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
+ 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 cpu.architecture compiler.constants ;
+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
-USING: compiler.generator help.markup help.syntax words io parser
+USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io debugger words fry
-compiler.units continuations vocabs assocs dlists definitions
-math threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state compiler.generator
-compiler.errors compiler.tree.builder compiler.tree.optimizer ;
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.codegen ;
IN: compiler
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
SYMBOL: +failed+
: ripple-up ( words -- )
[ "compiled-effect" set-word-prop ]
2bi ;
-: compile-begins ( word -- )
+: start ( word -- )
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
f swap compiler-error ;
-: compile-failed ( word error -- )
+: fail ( word error -- )
[ swap compiler-error ]
[
drop
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
- ] 2bi ;
+ ] 2bi
+ return ;
-: compile-succeeded ( effect word -- )
+: frontend ( word -- effect nodes )
+ [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
] [ drop ] if
] tri ;
+! Only switch this off for debugging.
+SYMBOL: compile-dependencies?
+
+t compile-dependencies? set-global
+
+: save-asm ( asm -- )
+ [ [ code>> ] [ label>> ] bi compiled get set-at ]
+ [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
+ bi ;
+
+: backend ( nodes word -- )
+ build-cfg [
+ build-mr
+ linear-scan
+ build-stack-frame
+ generate
+ save-asm
+ ] each ;
+
: (compile) ( word -- )
'[
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
-
_ {
- [ compile-begins ]
- [
- [ build-tree-from-word ] [ compile-failed return ] recover
- optimize-tree
- ]
- [ dup generate ]
- [ compile-succeeded ]
+ [ start ]
+ [ frontend ]
+ [ backend ]
+ [ finish ]
} cleave
] with-return ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup math kernel
-words strings alien compiler.generator ;
-IN: compiler.generator.fixup
-
-HELP: frame-required
-{ $values { "n" "a non-negative integer" } }
-{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-
-HELP: add-literal
-{ $values { "obj" object } { "n" integer } }
-{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-
-HELP: rel-dlsym
-{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
-{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
-} ;
-
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+++ /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 cpu.architecture
-math.order accessors growable ;
-IN: compiler.generator.fixup
-
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: compute-stack-frame-size ( code -- n )
- no-stack-frame [
- dup frame-required? [ n>> max ] [ drop ] if
- ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
-
-: code-format 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
-
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-
-M: label fixup*
- compiled-offset >>offset drop ;
-
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-: if-stack-frame ( frame-size quot -- )
- swap dup no-stack-frame =
- [ 2drop ] [ stack-frame-size swap call ] if ; inline
-
-M: word fixup*
- {
- { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
- } case ;
-
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-! Relocation classes
-: rc-absolute-cell 0 ;
-: rc-absolute 1 ;
-: rc-relative 2 ;
-: rc-absolute-ppc-2/2 3 ;
-: rc-relative-ppc-2 4 ;
-: rc-relative-ppc-3 5 ;
-: rc-relative-arm-3 6 ;
-: rc-indirect-arm 7 ;
-: rc-indirect-arm-pc 8 ;
-
-: rc-absolute? ( n -- ? )
- dup rc-absolute-cell =
- over rc-absolute =
- rot rc-absolute-ppc-2/2 = or or ;
-
-! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym 1 ;
-: rt-literal 2 ;
-: rt-dispatch 3 ;
-: rt-xt 4 ;
-: rt-here 5 ;
-: rt-label 6 ;
-: rt-immediate 7 ;
-
-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
- dup label>> swap class>> 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: frame-required fixup* drop ;
-
-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 ( code -- literals relocation labels code )
- [
- init-fixup
- dup compute-stack-frame-size swap [ fixup* ] each drop
-
- literal-table get >array
- relocation-table get >byte-array
- label-table get resolve-labels
- ] { } make ;
+++ /dev/null
-Support for generation of relocatable code
+++ /dev/null
-USING: help.markup help.syntax words debugger
-compiler.generator.fixup compiler.generator.registers quotations
-kernel vectors arrays effects sequences ;
-IN: compiler.generator
-
-ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
-$nl
-"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces? }
-"Assembler intrinsics can be defined for low-level optimization:"
-{ $subsection define-intrinsic }
-{ $subsection define-intrinsics }
-{ $subsection define-if-intrinsic }
-{ $subsection define-if-intrinsics }
-"The main entry point into the code generator:"
-{ $subsection generate } ;
-
-ABOUT: "generator"
-
-HELP: compiled
-{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
-
-HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiled-stack-traces?
-{ $values { "?" "a boolean" } }
-{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
-
-HELP: begin-compiling
-{ $values { "word" word } { "label" word } }
-{ $description "Prepares to generate machine code for a word." } ;
-
-HELP: with-generator
-{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
-{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
-
-HELP: generate-node
-{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
-{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate-nodes
-{ $values { "nodes" "a sequence of nodes" } }
-{ $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate
-{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
-{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
-
-HELP: define-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
-{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: define-intrinsic
-{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
-{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: if>boolean-intrinsic
-{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
-{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
-
-HELP: define-if-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
-{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
-$nl
-"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
-$nl
-"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
-{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
-
-HELP: define-if-intrinsic
-{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
-{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
-$nl
-"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes combinators
-cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math math.parser namespaces make
-prettyprint quotations sequences system threads words vectors
-sets deques continuations.private summary alien alien.c-types
-alien.structs alien.strings alien.arrays libc compiler.errors
-stack-checker.inlining compiler.tree compiler.tree.builder
-compiler.tree.combinators compiler.tree.propagation.info
-compiler.generator.fixup compiler.generator.registers
-compiler.generator.iterator ;
-IN: compiler.generator
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
- {
- { [ dup "forgotten" word-prop ] [ ] }
- { [ dup compiled get key? ] [ ] }
- { [ dup inlined-block? ] [ ] }
- { [ dup primitive? ] [ ] }
- [ dup compile-queue get push-front ]
- } cond drop ;
-
-: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: compiling-word
-
-SYMBOL: compiling-label
-
-SYMBOL: compiling-loops
-
-! Label of current word, after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-: begin-compiling ( word label -- )
- H{ } clone compiling-loops set
- compiling-label set
- compiling-word set
- compiled-stack-traces?
- compiling-word get f ?
- 1vector literal-table set
- f compiling-label get compiled get set-at ;
-
-: save-machine-code ( literals relocation labels code -- )
- 4array compiling-label get compiled get set-at ;
-
-: with-generator ( nodes word label quot -- )
- [
- >r begin-compiling r>
- { } make fixup
- save-machine-code
- ] with-scope ; inline
-
-GENERIC: generate-node ( node -- next )
-
-: generate-nodes ( nodes -- )
- [ current-node generate-node ] iterate-nodes
- end-basic-block ;
-
-: init-generate-nodes ( -- )
- init-templates
- %save-word-xt
- %prologue-later
- current-label-start define-label
- current-label-start resolve-label ;
-
-: generate ( nodes word label -- )
- [
- init-generate-nodes
- [ generate-nodes ] with-node-iterator
- ] with-generator ;
-
-: intrinsics ( #call -- quot )
- word>> "intrinsics" word-prop ;
-
-: if-intrinsics ( #call -- quot )
- word>> "if-intrinsics" word-prop ;
-
-! node
-M: node generate-node drop iterate-next ;
-
-: %jump ( word -- )
- dup compiling-label get eq?
- [ drop current-label-start get ] [ %epilogue-later ] if
- %jump-label ;
-
-: generate-call ( label -- next )
- dup maybe-compile
- end-basic-block
- dup compiling-loops get at [
- %jump-label f
- ] [
- tail-call? [
- %jump f
- ] [
- 0 frame-required
- %call
- iterate-next
- ] if
- ] ?if ;
-
-! #recursive
-: compile-recursive ( node -- next )
- dup label>> id>> generate-call >r
- [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
- r> ;
-
-: compiling-loop ( word -- )
- <label> dup resolve-label swap compiling-loops get set-at ;
-
-: compile-loop ( node -- next )
- end-basic-block
- [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
- iterate-next ;
-
-M: #recursive generate-node
- dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-
-! #if
-: end-false-branch ( label -- )
- tail-call? [ %return drop ] [ %jump-label ] if ;
-
-: generate-branch ( nodes -- )
- [ copy-templates generate-nodes ] with-scope ;
-
-: generate-if ( node label -- next )
- <label> [
- >r >r children>> first2 swap generate-branch
- r> r> end-false-branch resolve-label
- generate-branch
- init-templates
- ] keep resolve-label iterate-next ;
-
-M: #if generate-node
- [ <label> dup %jump-f ]
- H{ { +input+ { { f "flag" } } } }
- with-template
- generate-if ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
- gensym [
- [
- copy-templates
- %save-dispatch-xt
- %prologue-later
- [ generate-nodes ] with-node-iterator
- %return
- ] with-generator
- ] keep ;
-
-: dispatch-branches ( node -- )
- children>> [
- compiling-word get dispatch-branch
- %dispatch-label
- ] each ;
-
-: generate-dispatch ( node -- )
- %dispatch dispatch-branches init-templates ;
-
-M: #dispatch generate-node
- #! The order here is important, dispatch-branches must
- #! run after %dispatch, so that each branch gets the
- #! correct register state
- tail-call? [
- generate-dispatch iterate-next
- ] [
- compiling-word get gensym [
- [
- init-generate-nodes
- generate-dispatch
- ] with-generator
- ] keep generate-call
- ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
- "intrinsics" set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
- 2array 1array define-intrinsics ;
-
-: define-if>branch-intrinsics ( word intrinsics -- )
- "if-intrinsics" set-word-prop ;
-
-: if>boolean-intrinsic ( quot -- )
- "false" define-label
- "end" define-label
- "false" get swap call
- t "if-scratch" get load-literal
- "end" get %jump-label
- "false" resolve-label
- f "if-scratch" get load-literal
- "end" resolve-label
- "if-scratch" get phantom-push ; inline
-
-: define-if>boolean-intrinsics ( word intrinsics -- )
- [
- >r [ if>boolean-intrinsic ] curry r>
- { { f "if-scratch" } } +scratch+ associate assoc-union
- ] assoc-map "intrinsics" set-word-prop ;
-
-: define-if-intrinsics ( word intrinsics -- )
- [ +input+ associate ] assoc-map
- 2dup define-if>branch-intrinsics
- define-if>boolean-intrinsics ;
-
-: define-if-intrinsic ( word quot inputs -- )
- 2array 1array define-if-intrinsics ;
-
-: do-if-intrinsic ( pair -- next )
- <label> [ swap do-template skip-next ] keep generate-if ;
-
-: find-intrinsic ( #call -- pair/f )
- intrinsics find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
- node@ {
- { [ dup length 2 < ] [ 2drop f ] }
- { [ dup second #if? ] [ drop if-intrinsics find-template ] }
- [ 2drop f ]
- } cond ;
-
-M: #call generate-node
- dup node-input-infos [ class>> ] map set-operand-classes
- dup find-if-intrinsic [
- do-if-intrinsic
- ] [
- dup find-intrinsic [
- do-template iterate-next
- ] [
- word>> generate-call
- ] ?if
- ] ?if ;
-
-! #call-recursive
-M: #call-recursive generate-node label>> id>> generate-call ;
-
-! #push
-M: #push generate-node
- literal>> <constant> phantom-push iterate-next ;
-
-! #shuffle
-M: #shuffle generate-node
- shuffle-effect phantom-shuffle iterate-next ;
-
-M: #>r generate-node
- [ in-d>> length ] [ out-r>> empty? ] bi
- [ phantom-drop ] [ phantom->r ] if
- iterate-next ;
-
-M: #r> generate-node
- [ in-r>> length ] [ out-d>> empty? ] bi
- [ phantom-rdrop ] [ phantom-r> ] if
- iterate-next ;
-
-! #return
-M: #return generate-node
- drop end-basic-block %return f ;
-
-M: #return-recursive generate-node
- end-basic-block
- label>> id>> compiling-loops get key?
- [ %return ] unless f ;
-
-! #alien-invoke
-: 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 ;
-
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
-
-: alien-stack-frame ( params -- n )
- stack-frame new
- swap
- [ return>> return-size >>return ]
- [ alien-parameters parameter-sizes drop >>params ] bi
- dup [ params>> ] [ return>> ] bi + >>size
- dup size>> stack-frame-size >>total-size ;
-
-: with-stack-frame ( params quot -- )
- swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
- call
- stack-frame off ; inline
-
-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 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-M: stack-params reg-class-variable drop stack-params ;
-
-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 ;
-
-: reg-class-full? ( class -- ? )
- [ 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 -- types )
- 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-node
- params>>
- dup [
- end-basic-block
- %prepare-alien-invoke
- dup objects>registers
- %prepare-var-args
- dup alien-invoke-dlsym %alien-invoke
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
-
-! #alien-indirect
-M: #alien-indirect generate-node
- params>>
- dup [
- ! Flush registers
- end-basic-block
- ! Save registers for GC
- %prepare-alien-invoke
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
-
-! #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" = ] [ drop stack-frame get params>> ] }
- { [ 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 ;
-
-: generate-callback ( params -- )
- dup xt>> dup [
- init-templates
- %prologue-later
- dup [
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri
- ] with-stack-frame
- ] with-generator ;
-
-M: #alien-callback generate-node
- end-basic-block
- params>> generate-callback iterate-next ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.generator.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? ] [ #terminate? ] bi 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
-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 namespaces make
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order cpu.architecture
-compiler.generator.fixup ;
-IN: compiler.generator.registers
-
-SYMBOL: +input+
-SYMBOL: +output+
-SYMBOL: +scratch+
-SYMBOL: +clobber+
-SYMBOL: known-tag
-
-<PRIVATE
-
-! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-vregs* ( obj -- )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-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
-
-MIXIN: value
-
-PRIVATE>
-
-: operand-class ( operand -- class )
- operand-class* object or ;
-
-! Default implementation
-M: value set-operand-class 2drop ;
-M: value operand-class* drop f ;
-M: value live-vregs* drop ;
-M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
-M: value lazy-store 2drop ;
-
-! A scratch register for computations
-TUPLE: vreg n reg-class ;
-
-C: <vreg> vreg ( n reg-class -- vreg )
-
-M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
-M: vreg live-vregs* , ;
-
-M: vreg move-spec
- reg-class>> {
- { [ dup int-regs? ] [ f ] }
- { [ dup float-regs? ] [ float ] }
- } cond nip ;
-
-M: vreg operand-class*
- reg-class>> {
- { [ dup int-regs? ] [ f ] }
- { [ dup float-regs? ] [ float ] }
- } cond nip ;
-
-INSTANCE: vreg value
-
-! Temporary register for stack shuffling
-SINGLETON: temp-reg
-
-M: temp-reg move-spec drop f ;
-
-INSTANCE: temp-reg value
-
-! A data stack location.
-TUPLE: ds-loc n class ;
-
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc live-loc?
- over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-! A retain stack location.
-TUPLE: rs-loc n class ;
-
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc live-loc?
- over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-UNION: loc ds-loc rs-loc ;
-
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
-M: loc move-spec drop loc ;
-
-INSTANCE: loc value
-
-M: f move-spec drop loc ;
-M: f operand-class* ;
-
-! 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-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
-M: cached move-spec drop cached ;
-M: cached live-vregs* vreg>> live-vregs* ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-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* ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-
-: <tagged> ( vreg -- tagged )
- f tagged boa ;
-
-M: tagged v>operand vreg>> v>operand ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
-M: tagged move-spec drop f ;
-M: tagged live-vregs* vreg>> , ;
-
-INSTANCE: tagged value
-
-! Unboxed alien pointers
-TUPLE: unboxed-alien vreg ;
-C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand vreg>> v>operand ;
-M: unboxed-alien operand-class* drop simple-alien ;
-M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-alien value
-
-TUPLE: unboxed-byte-array vreg ;
-C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand vreg>> v>operand ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
-M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-byte-array value
-
-TUPLE: unboxed-f vreg ;
-C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand vreg>> v>operand ;
-M: unboxed-f operand-class* drop \ f ;
-M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-f value
-
-TUPLE: unboxed-c-ptr vreg ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand vreg>> v>operand ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
-M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-c-ptr value
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-M: constant operand-class* value>> class ;
-M: constant move-spec class ;
-
-INSTANCE: constant value
-
-<PRIVATE
-
-! Moving values between locations and registers
-: %move-bug ( -- * ) "Bug in generator.registers" throw ;
-
-: %unbox-c-ptr ( dst src -- )
- dup operand-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.
- temp-reg over %move
- operand-class temp-reg
- tagged new
- swap >>vreg
- swap >>class
- %move ;
-
-: %move ( dst src -- )
- 2dup [ move-spec ] bi@ 2array {
- { { f f } [ %move-bug ] }
- { { f unboxed-c-ptr } [ %move-bug ] }
- { { f unboxed-byte-array } [ %move-bug ] }
-
- { { f constant } [ value>> swap load-literal ] }
-
- { { f float } [ %box-float ] }
- { { f unboxed-alien } [ %box-alien ] }
- { { 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.
- [
- over zero? [ 2drop ] [ execute ] if 0
- ] curry 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> ] curry 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) ] curry each ; inline
-
-: adjust-phantom ( n phantom -- )
- swap [ + ] curry change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
- swap [ cut* swap ] curry 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-vregs ( -- seq )
- [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
-
-: (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 ;
-
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-! Computing free registers and initializing allocator
-: reg-spec>class ( spec -- class )
- float eq? double-float-regs int-regs ? ;
-
-: free-vregs ( reg-class -- seq )
- #! Free vregs in a given register class
- \ free-vregs get at ;
-
-: alloc-vreg ( spec -- reg )
- [ reg-spec>class free-vregs pop ] 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 ;
-
-: allocation ( value spec -- reg-class )
- {
- { [ dup quotation? ] [ 2drop f ] }
- { [ 2dup compatible? ] [ 2drop f ] }
- [ nip reg-spec>class ]
- } cond ;
-
-: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap operand-class
- over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
- 2dup allocation [
- dupd alloc-vreg-for dup rot %move
- ] [
- drop
- ] if ;
-
-: (compute-free-vregs) ( used class -- vector )
- #! Find all vregs in 'class' which are not in 'used'.
- [ vregs length reverse ] keep
- [ <vreg> ] curry map swap diff
- >vector ;
-
-: compute-free-vregs ( -- )
- #! Create a new hashtable for thee free-vregs variable.
- live-vregs
- { int-regs double-float-regs }
- [ 2dup (compute-free-vregs) ] H{ } map>assoc
- \ free-vregs set
- drop ;
-
-M: loc lazy-store
- 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
-
-: do-shuffle ( hash -- )
- dup assoc-empty? [
- drop
- ] [
- "live-locs" set
- [ lazy-store ] each-loc
- ] if ;
-
-: fast-shuffle ( locs -- )
- #! We have enough free registers to load all shuffle inputs
- #! at once
- [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
-
-: minimal-ds-loc ( phantom -- n )
- #! When shuffling more values than can fit in registers, we
- #! need to find an area on the data stack which isn't in
- #! use.
- [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
-
-: find-tmp-loc ( -- n )
- #! Find an area of the data stack which is not referenced
- #! from the phantom stacks. We can clobber there all we want
- [ minimal-ds-loc ] each-phantom min 1- ;
-
-: slow-shuffle-mapping ( locs tmp -- pairs )
- >r dup length r>
- [ swap - <ds-loc> ] curry map zip ;
-
-: slow-shuffle ( locs -- )
- #! We don't have enough free registers to load all shuffle
- #! inputs, so we use a single temporary register, together
- #! with the area of the data stack above the stack pointer
- find-tmp-loc slow-shuffle-mapping [
- [
- swap dup cached? [ vreg>> ] when %move
- ] assoc-each
- ] keep >hashtable do-shuffle ;
-
-: fast-shuffle? ( live-locs -- ? )
- #! Test if we have enough free registers to load all
- #! shuffle inputs at once.
- int-regs free-vregs [ length ] bi@ <= ;
-
-: finalize-locs ( -- )
- #! Perform any deferred stack shuffling.
- [
- \ free-vregs [ [ clone ] assoc-map ] change
- live-locs dup fast-shuffle?
- [ fast-shuffle ] [ slow-shuffle ] if
- ] with-scope ;
-
-: finalize-vregs ( -- )
- #! Store any vregs to their final stack locations.
- [
- dup loc? over cached? or [ 2drop ] [ %move ] if
- ] each-loc ;
-
-: reset-phantom ( phantom -- )
- #! Kill register assignments but preserve constants and
- #! class information.
- dup phantom-locs*
- over stack>> [
- dup constant? [ nip ] [
- operand-class over set-operand-class
- ] if
- ] 2map
- over stack>> delete-all
- swap stack>> push-all ;
-
-: reset-phantoms ( -- )
- [ reset-phantom ] each-phantom ;
-
-: finalize-contents ( -- )
- finalize-locs finalize-vregs reset-phantoms ;
-
-! Loading stacks to vregs
-: free-vregs? ( int# float# -- ? )
- double-float-regs free-vregs length <=
- >r int-regs free-vregs length <= r> and ;
-
-: phantom&spec ( phantom spec -- phantom' spec' )
- >r stack>> r>
- [ length f pad-left ] keep
- [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
- >r phantom&spec r> 2all? ; inline
-
-: 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
- [ >r stack>> r> substitute-here ] curry each-phantom ;
-
-: set-operand ( value var -- )
- >r dup constant? [ value>> ] when r> set ;
-
-: lazy-load ( values template -- )
- #! Set operand vars here.
- 2dup [ first (lazy-load) ] 2map
- dup rot [ second set-operand ] 2each
- substitute-vregs ;
-
-: load-inputs ( -- )
- +input+ get
- [ length phantom-datastack get phantom-input ] keep
- lazy-load ;
-
-: output-vregs ( -- seq seq )
- +output+ +clobber+ [ get [ get ] map ] bi@ ;
-
-: clash? ( seq -- ? )
- phantoms [ stack>> ] bi@ append [
- dup cached? [ vreg>> ] when swap member?
- ] with contains? ;
-
-: outputs-clash? ( -- ? )
- output-vregs append clash? ;
-
-: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
-
-: count-input-vregs ( phantom spec -- )
- phantom&spec [
- >r dup cached? [ vreg>> ] when r> first allocation
- ] 2map count-vregs ;
-
-: count-scratch-regs ( spec -- )
- [ first reg-spec>class ] map count-vregs ;
-
-: guess-vregs ( dinput rinput scratch -- int# float# )
- [
- 0 int-regs set
- 0 double-float-regs set
- count-scratch-regs
- phantom-retainstack get swap count-input-vregs
- phantom-datastack get swap count-input-vregs
- int-regs get double-float-regs get
- ] with-scope ;
-
-: alloc-scratch ( -- )
- +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
-
-: guess-template-vregs ( -- int# float# )
- +input+ get { } +scratch+ get guess-vregs ;
-
-: template-inputs ( -- )
- ! Load input values into registers
- load-inputs
- ! Allocate scratch registers
- alloc-scratch
- ! If outputs clash, we write values back to the stack
- outputs-clash? [ finalize-contents ] when ;
-
-: template-outputs ( -- )
- +output+ get [ get ] map phantom-datastack get phantom-append ;
-
-: 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 quotation? [
- over constant?
- [ >r value>> r> call ] [ 2drop f ] if
- ] [
- 2drop t
- ] if ;
-
-: 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 operand-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( spec -- ? )
- phantom-datastack get +input+ rot at
- [ spec-matches? ] phantom&spec-agree? ;
-
-: ensure-template-vregs ( -- )
- guess-template-vregs free-vregs? [
- finalize-contents compute-free-vregs
- ] unless ;
-
-: clear-phantoms ( -- )
- [ stack>> delete-all ] each-phantom ;
-
-PRIVATE>
-
-: set-operand-classes ( classes -- )
- phantom-datastack get
- over length over add-locs
- stack>> [ set-operand-class ] 2reverse-each ;
-
-: end-basic-block ( -- )
- #! 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
- clear-phantoms
- finalize-heights
- fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
-
-: with-template ( quot hash -- )
- clone [
- ensure-template-vregs
- template-inputs call template-outputs
- ] bind
- compute-free-vregs ; inline
-
-: do-template ( pair -- )
- #! Use with return value from find-template
- first2 with-template ;
-
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
-
-: init-templates ( -- )
- #! Initialize register allocator.
- V{ } clone fresh-objects set
- <phantom-datastack> phantom-datastack set
- <phantom-retainstack> phantom-retainstack set
- compute-free-vregs ;
-
-: copy-templates ( -- )
- #! Copies register allocator state, used when compiling
- #! branches.
- fresh-objects [ clone ] change
- phantom-datastack [ clone ] change
- phantom-retainstack [ clone ] change
- compute-free-vregs ;
-
-: find-template ( templates -- pair/f )
- #! Pair has shape { quot hash }
- [ second template-matches? ] find nip ;
-
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
-: 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 ;
+++ /dev/null
-Register allocation and intrinsic selection
+++ /dev/null
-Final stage of compilation generates machine code from dataflow IR
\ (wrapper) { } { wrapper } define-primitive
\ (wrapper) make-flushable
-: (set-slot) ( val obj n -- ) missing-intrinsic ;
+: (slot) ( obj n tag# -- val ) missing-intrinsic ;
-\ (set-slot) { object object fixnum } { } define-primitive
+\ (slot) { object fixnum fixnum } { object } define-primitive
+
+: (set-slot) ( val obj n tag# -- ) missing-intrinsic ;
+
+\ (set-slot) { object object fixnum fixnum } { } define-primitive
: (write-barrier) ( obj -- ) missing-intrinsic ;
{ "float" "h" }
;
-: <rect>
+: <rect> ( x y w h -- rect )
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
] compile-call
b>>
] unit-test
+
+: mutable-value-bug-1 ( a b -- c )
+ swap [
+ { tuple } declare 1 slot
+ ] [
+ 0 slot
+ ] if ;
+
+[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+
+: mutable-value-bug-2 ( a b -- c )
+ swap [
+ 0 slot
+ ] [
+ { tuple } declare 1 slot
+ ] if ;
+
+[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
+++ /dev/null
-! Testing templates machinery without compiling anything
-IN: compiler.tests
-USING: compiler compiler.generator compiler.generator.registers
-compiler.generator.registers.private tools.test namespaces
-sequences words kernel math effects definitions compiler.units
-accessors cpu.architecture make ;
-
-: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
-
-[
- [ ] [ init-templates ] unit-test
-
- [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
-
- [ ] [ 0 <int-vreg> phantom-push ] unit-test
-
- [ ] [ compute-free-vregs ] unit-test
-
- [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
-
- [ f ] [
- [
- copy-templates
- 1 <int-vreg> phantom-push
- compute-free-vregs
- 1 <int-vreg> int-regs free-vregs member?
- ] with-scope
- ] unit-test
-
- [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- [ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
-
- [ 3 ] [ live-locs length ] unit-test
-
- [ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
-
- [ 2 ] [ live-locs length ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- H{ } clone compiled set
-
- [ ] [ gensym gensym begin-compiling ] unit-test
-
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
- 3 fresh-object
-
- [ f ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-[
- [ ] [ init-templates ] unit-test
-
- H{
- { +input+ { { f "x" } } }
- } clone [
- [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
- [ ] [ finalize-contents ] unit-test
- [ ] [ [ template-inputs ] { } make drop ] unit-test
- ] bind
-] with-scope
-
-! Test template picking strategy
-SYMBOL: template-chosen
-
-: template-test ( a b -- c d ) ;
-
-\ template-test {
- {
- [
- 1 template-chosen get push
- ] H{
- { +input+ { { f "obj" } { [ ] "n" } } }
- { +output+ { "obj" "obj" } }
- }
- }
- {
- [
- 2 template-chosen get push
- ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +output+ { "obj" "n" } }
- }
- }
-} define-intrinsics
-
-[ V{ 2 } ] [
- V{ } clone template-chosen set
- 0 0 [ template-test ] compile-call 2drop
- template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
- V{ } clone template-chosen set
- 1 [ dup 0 template-test ] compile-call 3drop
- template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
- V{ } clone template-chosen set
- 1 [ 0 template-test ] compile-call 2drop
- template-chosen get
-] unit-test
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- ! dup dup
- [ ] [
- T{ effect f { "x" } { "x" "x" } } phantom-shuffle
- T{ effect f { "x" } { "x" "x" } } phantom-shuffle
- ] unit-test
-
- ! This is not empty since a load instruction is emitted
- [ f ] [
- [ { { f "x" } } +input+ set load-inputs ] { } make
- empty?
- ] unit-test
-
- ! This is empty since we already loaded the value
- [ t ] [
- [ { { f "x" } } +input+ set load-inputs ] { } make
- empty?
- ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- ! >r r>
- [ ] [
- 1 phantom->r
- 1 phantom-r>
- ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
- ! >r r>
- [ ] [
- 1 phantom->r
- 1 phantom-r>
- ] unit-test
-
- [ ] [ { object } set-operand-classes ] unit-test
-
- ! This is empty since we didn't change the stack
- [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
- [ ] [ init-templates ] unit-test
-
- [ ] [ { object object } set-operand-classes ] unit-test
-
- ! 2dup
- [ ] [
- T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
- phantom-shuffle
- ] unit-test
-
- [ ] [
- 2 phantom-datastack get phantom-input
- [ { { f "a" } { f "b" } } lazy-load ] { } make drop
- ] unit-test
-
- [ t ] [
- phantom-datastack get stack>> [ cached? ] all?
- ] unit-test
-
- ! >r
- [ ] [
- 1 phantom->r
- ] unit-test
-
- ! This should not fail
- [ ] [ [ end-basic-block ] { } make drop ] unit-test
-] with-scope
-
-! Regression
-SYMBOL: templates-chosen
-
-V{ } clone templates-chosen set
-
-: template-choice-1 ;
-
-\ template-choice-1
-[ "template-choice-1" templates-chosen get push ]
-H{
- { +input+ { { f "obj" } { [ ] "n" } } }
- { +output+ { "obj" } }
-} define-intrinsic
-
-: template-choice-2 ;
-
-\ template-choice-2
-[ "template-choice-2" templates-chosen get push drop ]
-{ { f "x" } { f "y" } } define-if-intrinsic
-
-[ ] [
- [ 2 template-choice-1 template-choice-2 ]
- [ define-temp ] with-compilation-unit drop
-] unit-test
-
-[ V{ "template-choice-1" "template-choice-2" } ]
-[ templates-chosen get ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
-fry namespaces make math math.order memoize classes.builtin
-classes.tuple.private slots.private combinators layouts
-byte-arrays alien.accessors
+fry namespaces make math math.private math.order memoize
+classes.builtin classes.tuple.private classes.algebra
+slots.private combinators layouts byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
compiler.tree.combinators
GENERIC: finalize* ( node -- nodes )
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
+
+: splice-final ( quot -- nodes ) splice-quot finalize ;
+
M: #copy finalize* drop f ;
M: #shuffle finalize*
word>> "predicating" word-prop builtin-class? ;
MEMO: builtin-predicate-expansion ( word -- nodes )
- def>> splice-quot ;
+ def>> splice-final ;
: expand-builtin-predicate ( #call -- nodes )
word>> builtin-predicate-expansion ;
-: first-literal ( #call -- obj ) node-input-infos first literal>> ;
-
-: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
-
: expand-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
last-literal tuple-layout?
] [ drop f ] if ;
-MEMO: (tuple-boa-expansion) ( n -- quot )
+MEMO: (tuple-boa-expansion) ( n -- nodes )
[
- [ 2 + ] map <reversed>
- [ '[ [ _ set-slot ] keep ] % ] each
- ] [ ] make ;
+ [ '[ _ (tuple) ] % ]
+ [
+ [ 2 + ] map <reversed>
+ [ '[ [ _ set-slot ] keep ] % ] each
+ ] bi
+ ] [ ] make '[ _ dip ] splice-final ;
: tuple-boa-expansion ( layout -- quot )
#! No memoization here since otherwise we'd hang on to
#! tuple layout objects.
- size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
+ size>> (tuple-boa-expansion)
+ [ over 1 set-slot ] splice-final append ;
: expand-tuple-boa ( #call -- node )
last-literal tuple-boa-expansion ;
MEMO: <array>-expansion ( n -- quot )
[
[ swap (array) ] %
- [ \ 2dup , , [ swap set-array-nth ] % ] each
+ [ '[ _ over 1 set-slot ] % ]
+ [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
\ nip ,
- ] [ ] make splice-quot ;
+ ] [ ] make splice-final ;
: expand-<array>? ( #call -- ? )
dup word>> \ <array> eq? [
first-literal dup integer?
- [ 0 32 between? ] [ drop f ] if
+ [ 0 8 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<array> ( #call -- node )
MEMO: <byte-array>-expansion ( n -- quot )
[
[ (byte-array) ] %
- bytes>cells [ cell * ] map
- [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
- ] [ ] make splice-quot ;
+ [ '[ _ over 1 set-slot ] % ]
+ [
+ bytes>cells [
+ cell *
+ '[ 0 over _ set-alien-unsigned-cell ] %
+ ] each
+ ] bi
+ ] [ ] make splice-final ;
: expand-<byte-array>? ( #call -- ? )
dup word>> \ <byte-array> eq? [
first-literal dup integer?
- [ 0 128 between? ] [ drop f ] if
+ [ 0 32 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<byte-array> ( #call -- nodes )
first-literal <byte-array>-expansion ;
+MEMO: <ratio>-expansion ( -- quot )
+ [ (ratio) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
+
+: expand-<ratio> ( #call -- nodes )
+ drop <ratio>-expansion ;
+
+MEMO: <complex>-expansion ( -- quot )
+ [ (complex) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
+
+: expand-<complex> ( #call -- nodes )
+ drop <complex>-expansion ;
+
+MEMO: <wrapper>-expansion ( -- quot )
+ [ (wrapper) [ 1 set-slot ] keep ] splice-final ;
+
+: expand-<wrapper> ( #call -- nodes )
+ drop <wrapper>-expansion ;
+
+MEMO: slot-expansion ( tag -- nodes )
+ '[ _ (slot) ] splice-final ;
+
+: value-tag ( node value -- n )
+ node-value-info class>> class-tag ;
+
+: expand-slot ( #call -- nodes )
+ dup dup in-d>> first value-tag [ slot-expansion ] [ ] ?if ;
+
+MEMO: set-slot-expansion ( write-barrier? tag# -- nodes )
+ [ '[ [ _ (set-slot) ] [ drop (write-barrier) ] 2bi ] ]
+ [ '[ _ (set-slot) ] ]
+ bi ? splice-final ;
+
+: expand-set-slot ( #call -- nodes )
+ dup dup in-d>> second value-tag [
+ [ dup in-d>> first node-value-info class>> immediate class<= not ] dip
+ set-slot-expansion
+ ] when* ;
+
M: #call finalize*
{
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
{ [ dup expand-<array>? ] [ expand-<array> ] }
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
- [ ]
+ [
+ dup word>> {
+ { \ <ratio> [ expand-<ratio> ] }
+ { \ <complex> [ expand-<complex> ] }
+ { \ <wrapper> [ expand-<wrapper> ] }
+ { \ set-slot [ expand-set-slot ] }
+ { \ slot [ expand-slot ] }
+ [ drop ]
+ } case
+ ]
} cond ;
M: node finalize* ;
-
-: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
classes alien byte-arrays combinators words sets ;
IN: cpu.architecture
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj vreg -- )
+GENERIC# load-literal 1 ( obj reg -- )
HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame-size cpu ( frame-size -- n )
-TUPLE: stack-frame total-size size params return ;
-
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
-: %prologue-later ( -- ) \ %prologue-later , ;
-
! Tear down stack frame
HOOK: %epilogue cpu ( n -- )
-: %epilogue-later ( -- ) \ %epilogue-later , ;
-
-! Store word XT in stack frame
-HOOK: %save-word-xt cpu ( -- )
-
-! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt cpu ( -- )
-
-M: object %save-dispatch-xt %save-word-xt ;
-
! Call another word
HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label -- )
+HOOK: %jump-f cpu ( label vreg -- )
-HOOK: %dispatch cpu ( -- )
+! Test if vreg is 't' or not
+HOOK: %jump-t cpu ( label vreg -- )
+
+HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch-label cpu ( word -- )
! Store vreg to stack
HOOK: %replace cpu ( vreg loc -- )
+! Copy values between vregs
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+
! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src temp -- )
! FFI stuff
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
-! Do we pass explode value structs?
+! Do we pass value structs by value or hidden reference?
HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup cpu ( alien-node -- )
+HOOK: %cleanup cpu ( params -- )
+
+M: object %cleanup ( params -- ) drop ;
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
+HOOK: %callback-return cpu ( params -- )
+
+M: object %callback-return drop %return ;
HOOK: %prepare-alien-indirect cpu ( -- )
M: stack-params param-regs drop f ;
-GENERIC: v>operand ( obj -- operand )
-
-M: integer v>operand tag-fixnum ;
-
-M: f v>operand drop \ f tag-number ;
-
-M: object load-literal v>operand load-indirect ;
-
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer v>operand small-enough? ;
+M: object load-literal load-indirect ;
: if-small-struct ( n size true false -- ? )
[ over not over struct-small-enough? and ] 2dip
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-HOOK: %box-alien cpu ( dst src -- )
+HOOK: %box-alien cpu ( dst src temp -- )
-! GC check
-HOOK: %gc cpu ( -- )
+! Allocation
+HOOK: %allot cpu ( dst size type tag temp -- )
-: operand ( var -- op ) get v>operand ; inline
+HOOK: %write-barrier cpu ( src card# table -- )
-: unique-operands ( operands quot -- )
- >r [ operand ] map prune r> each ; inline
+! GC check
+HOOK: %gc cpu ( -- )
M: ppc %return ( -- ) %epilogue-later BLR ;
-M: ppc %unwind drop %return ;
-
M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
! Unbox former top of data stack to return registers
unbox-return ;
-M: ppc %cleanup ( alien-node -- ) drop ;
-
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
-cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words compiler.generator.registers
-compiler.generator.fixup compiler.generator system layouts
-combinators command-line compiler compiler.units io
-vocabs.loader accessors init ;
+USING: locals alien.c-types arrays kernel kernel.private math
+namespaces sequences stack-checker.known-words system layouts io
+vocabs.loader accessors init combinators command-line
+cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
+cpu.x86.allot cpu.architecture compiler compiler.units
+compiler.constants compiler.alien compiler.codegen
+compiler.codegen.fixup compiler.cfg.builder
+compiler.cfg.instructions ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! this on all platforms, sacrificing some stack space for
! code simplicity.
+M: x86.32 machine-registers
+ {
+ { int-regs { EAX ECX EDX EBP EBX } }
+ { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+ } ;
+
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
-M: temp-reg v>operand drop EBX ;
-
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
! Unbox EAX
unbox-return ;
-M: x86.32 %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
[ drop ]
} cond ;
-M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %callback-return ( n -- )
+ #! a) If the callback is stdcall, we have to clean up the
+ #! caller's stack frame.
+ #! b) If the callback is returning a large struct, we have
+ #! to fix ESP.
+ {
+ { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond RET ;
os windows? [
cell "longlong" c-type (>>align)
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
- JE
+ JNE
] { } define-if-intrinsic
\ (sse2?) { } { object } define-primitive
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
-cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces make sequences compiler.generator
-compiler.generator.registers compiler.generator.fixup system
+USING: accessors alien.c-types arrays kernel kernel.private math
+namespaces make sequences system
layouts alien alien.accessors alien.structs slots splitting
-assocs combinators ;
+assocs combinators cpu.x86.assembler
+cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
+cpu.x86.allot cpu.architecture compiler.constants
+compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder ;
IN: cpu.x86.64
+M: x86.64 machine-registers
+ {
+ { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+ { double-float-regs {
+ XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+ XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
+ } }
+ } ;
+
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
-M: temp-reg v>operand drop RBX ;
-
M: int-regs return-reg drop RAX ;
M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
! Unbox former top of data stack to return registers
unbox-return ;
-M: x86.64 %cleanup ( alien-node -- ) drop ;
+USE: cpu.x86.intrinsics
-M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
+: (%alien-get-4) ( -- )
+ small-reg-32 "offset" operand [] MOV ; inline
-USE: cpu.x86.intrinsics
+: %alien-unsigned-4 ( -- )
+ %prepare-alien-accessor
+ "value" operand small-reg = [
+ (%alien-get-4)
+ ] [
+ small-reg PUSH
+ (%alien-get-4)
+ "value" operand small-reg MOV
+ small-reg POP
+ ] if
+ "value" operand %tag-fixnum ; inline
+
+: (%alien-signed-4) ( -- )
+ (%alien-get-4)
+ "value" operand small-reg-32 MOVSX ;
+
+: %alien-signed-4 ( -- )
+ %prepare-alien-accessor
+ "value" operand small-reg = [
+ (%alien-signed-4)
+ ] [
+ small-reg PUSH
+ (%alien-signed-4)
+ small-reg POP
+ ] if
+ "value" operand %tag-fixnum ; inline
+
+: define-alien-unsigned-4-getter ( word -- )
+ [ %alien-unsigned-4 ] alien-integer-get-template define-intrinsic ;
+
+: define-alien-signed-4-getter ( word -- )
+ [ %alien-signed-4 ] alien-integer-get-template define-intrinsic ;
+
+: %set-alien-4 ( -- )
+ "value" operand "offset" operand = [
+ "value" operand %untag-fixnum
+ ] unless
+ %prepare-alien-accessor
+ small-reg "offset" operand = [
+ "value" operand "offset" operand XCHG
+ "value" operand [] small-reg-32 MOV
+ ] [
+ small-reg PUSH
+ small-reg "value" operand MOV
+ "offset" operand [] small-reg-32 MOV
+ small-reg POP
+ ] if ; inline
+
+: define-alien-4-setter ( word -- )
+ [ %set-alien-4 ] alien-integer-set-template define-intrinsic ;
! On 64-bit systems, the result of reading 4 bytes from memory
! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
+\ alien-unsigned-4 define-alien-unsigned-4-getter
+\ set-alien-unsigned-4 define-alien-4-setter
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
+\ alien-signed-4 define-alien-signed-4-getter
+\ set-alien-signed-4 define-alien-4-setter
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture cpu.x86.assembler
-cpu.x86.architecture kernel.private namespaces math sequences
-generic arrays compiler.generator compiler.generator.fixup
-compiler.generator.registers system layouts alien ;
+USING: kernel words kernel.private namespaces math math.private
+sequences generic arrays system layouts alien locals fry
+cpu.architecture cpu.x86.assembler cpu.x86.architecture
+compiler.constants compiler.cfg.templates compiler.cfg.builder
+compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86.allot
-: allot-reg ( -- reg )
- #! We temporarily use the datastack register, since it won't
- #! be accessed inside the quotation given to %allot in any
- #! case.
- ds-reg ;
+M:: x86 %write-barrier ( src card# table -- )
+ #! Mark the card pointed to by vreg.
+ ! Mark the card
+ card# src MOV
+ card# card-bits SHR
+ "cards_offset" f table %alien-global
+ table card# [+] card-mark <byte> MOV
-: (object@) ( n -- operand ) allot-reg swap [+] ;
-
-: object@ ( n -- operand ) cells (object@) ;
+ ! Mark the card deck
+ card# deck-bits card-bits - SHR
+ "decks_offset" f table %alien-global
+ table card# [+] card-mark <byte> MOV ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-: load-allot-ptr ( -- )
- allot-reg load-zone-ptr
- allot-reg PUSH
- allot-reg dup cell [+] MOV ;
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+ [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
+
+: inc-allot-ptr ( nursery-ptr n -- )
+ [ cell [+] ] dip 8 align ADD ;
+
+: store-header ( temp type -- )
+ [ [] ] [ type-number tag-fixnum ] bi* MOV ;
-: inc-allot-ptr ( n -- )
- allot-reg POP
- allot-reg cell [+] swap 8 align ADD ;
+: store-tagged ( dst tag -- )
+ tag-number OR ;
+
+M:: x86 %allot ( dst size type tag nursery-ptr -- )
+ nursery-ptr dst load-allot-ptr
+ dst type store-header
+ dst tag store-tagged
+ nursery-ptr size inc-allot-ptr ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
- 0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
-: store-header ( header -- )
- 0 object@ swap type-number tag-fixnum MOV ;
-
-: %allot ( header size quot -- )
- allot-reg PUSH
- swap >r >r
- load-allot-ptr
- store-header
- r> call
- r> inc-allot-ptr
- allot-reg POP ; inline
-
-: %store-tagged ( reg tag -- )
- >r dup fresh-object v>operand r>
- allot-reg swap tag-number OR
- allot-reg MOV ;
-
-M: x86 %box-float ( dst src -- )
- #! Only called by pentium4 backend, uses SSE2 instruction
- #! dest is a loc or a vreg
- float 16 [
- 8 (object@) swap v>operand MOVSD
- float %store-tagged
- ] %allot ;
-
-: %allot-bignum-signed-1 ( outreg inreg -- )
+: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
+
+:: %allot-bignum-signed-1 ( dst src temp -- )
#! on entry, inreg is a signed 32-bit quantity
#! exits with tagged ptr to bignum in outreg
#! 1 cell header, 1 cell length, 1 cell sign, + digits
#! length is the # of digits + sign
[
- { "end" "nonzero" "positive" "store" }
- [ define-label ] each
- dup v>operand 0 CMP ! is it zero?
+ { "end" "nonzero" "positive" "store" } [ define-label ] each
+ src 0 CMP ! is it zero?
"nonzero" get JNE
- 0 >bignum pick load-literal ! this is our result
+ ! Use cached zero value
+ 0 >bignum dst load-indirect
"end" get JMP
"nonzero" resolve-label
- bignum 4 cells [
- ! Write length
- 1 object@ 2 v>operand MOV
- ! Test sign
- dup v>operand 0 CMP
- "positive" get JGE
- 2 object@ 1 MOV ! negative sign
- dup v>operand NEG
- "store" get JMP
- "positive" resolve-label
- 2 object@ 0 MOV ! positive sign
- "store" resolve-label
- 3 object@ swap v>operand MOV
- ! Store tagged ptr in reg
- bignum %store-tagged
- ] %allot
+ ! Allocate a bignum
+ dst 4 cells bignum bignum temp %allot
+ ! Write length
+ dst 1 bignum@ 2 tag-fixnum MOV
+ ! Test sign
+ src 0 CMP
+ "positive" get JGE
+ dst 2 bignum@ 1 MOV ! negative sign
+ src NEG
+ "store" get JMP
+ "positive" resolve-label
+ dst 2 bignum@ 0 MOV ! positive sign
+ "store" resolve-label
+ dst 3 bignum@ src MOV
"end" resolve-label
] with-scope ;
-M: x86 %box-alien ( dst src -- )
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
[
{ "end" "f" } [ define-label ] each
- dup v>operand 0 CMP
+ src 0 CMP
"f" get JE
- alien 4 cells [
- 1 object@ f v>operand MOV
- 2 object@ f v>operand MOV
- ! Store src in alien-offset slot
- 3 object@ swap v>operand MOV
- ! Store tagged ptr in dst
- dup object %store-tagged
- ] %allot
+ dst 4 cells alien object temp %allot
+ dst 1 alien@ \ f tag-number MOV
+ dst 2 alien@ \ f tag-number MOV
+ ! Store src in alien-offset slot
+ dst 3 alien@ src MOV
"end" get JMP
"f" resolve-label
- f [ v>operand ] bi@ MOV
+ dst \ f tag-number MOV
"end" resolve-label
] with-scope ;
+
+: overflow-check ( word -- )
+ "end" define-label
+ "z" operand "x" operand MOV
+ "z" operand "y" operand pick execute
+ ! If the previous arithmetic operation overflowed, then we
+ ! turn the result into a bignum and leave it in EAX.
+ "end" get JNO
+ ! There was an overflow. Recompute the original operand.
+ { "y" "x" } [ %untag-fixnum ] unique-operands
+ "x" operand "y" operand rot execute
+ "z" operand "x" operand "y" operand %allot-bignum-signed-1
+ "end" resolve-label ; inline
+
+: overflow-template ( word insn -- )
+ '[ _ overflow-check ] T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "z" } } }
+ { output { "z" } }
+ { clobber { "x" "y" } }
+ { gc t }
+ } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+\ fixnum>bignum [
+ "x" operand %untag-fixnum
+ "y" operand "x" operand "scratch" operand %allot-bignum-signed-1
+] T{ template
+ { input { { f "x" } } }
+ { scratch { { f "y" } { f "scratch" } } }
+ { output { "y" } }
+ { clobber { "x" } }
+ { gc t }
+} define-intrinsic
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces make sequences words compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts combinators compiler.constants math.order ;
+math memory namespaces make sequences words system
+layouts combinators math.order locals compiler.constants
+compiler.cfg.registers compiler.cfg.instructions
+compiler.codegen.fixup ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu ( -- reg )
: reg-stack ( n reg -- op ) swap cells neg [+] ;
-M: ds-loc v>operand n>> ds-reg reg-stack ;
-M: rs-loc v>operand n>> rs-reg reg-stack ;
+GENERIC: loc>operand ( loc -- operand )
+
+M: ds-loc loc>operand n>> ds-reg reg-stack ;
+M: rs-loc loc>operand n>> rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
HOOK: temp-reg-2 cpu ( -- reg )
HOOK: fixnum>slot@ cpu ( op -- )
-
HOOK: prepare-division cpu ( -- )
-M: immediate load-literal v>operand swap v>operand MOV ;
+M: f load-literal
+ \ f tag-number MOV drop ;
+
+M: fixnum load-literal
+ swap tag-fixnum MOV ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( n -- i )
3 cells + align-stack ;
-M: x86 %save-word-xt ( -- )
- temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %prologue ( n -- )
+ temp-reg-1 0 MOV rc-absolute-cell rel-this
dup PUSH
- temp-reg v>operand PUSH
- 3 cells - decr-stack-reg ;
+ temp-reg-1 PUSH
+ stack-reg swap 3 cells - SUB ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- "stack_chain" f temp-reg v>operand %alien-global
- temp-reg v>operand [] stack-reg MOV
- temp-reg v>operand [] cell SUB
- temp-reg v>operand 2 cells [+] ds-reg MOV
- temp-reg v>operand 3 cells [+] rs-reg MOV ;
+ "stack_chain" f temp-reg-1 %alien-global
+ temp-reg-1 [] stack-reg MOV
+ temp-reg-1 [] cell SUB
+ temp-reg-1 2 cells [+] ds-reg MOV
+ temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
-M: x86 %jump-f ( label -- )
- "flag" operand f v>operand CMP JE ;
+M: x86 %jump-f ( label reg -- )
+ \ f tag-number CMP JE ;
+
+M: x86 %jump-t ( label reg -- )
+ \ f tag-number CMP JNE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
: align-code ( n -- )
0 <repetition> % ;
-M: x86 %dispatch ( -- )
- [
- %epilogue-later
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Untag and multiply to get a jump table offset
- "n" operand fixnum>slot@
- ! Add jump table base
- "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
- "n" operand "offset" operand ADD
- "n" operand HEX: 7f [+] JMP
- ! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code
- ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- { +clobber+ { "n" } }
- } with-template ;
+M:: x86 %dispatch ( src temp -- )
+ ! Load jump table base. We use a temporary register
+ ! since on AMD64 we have to load a 64-bit immediate. On
+ ! x86, this is redundant.
+ ! Untag and multiply to get a jump table offset
+ src fixnum>slot@
+ ! Add jump table base
+ temp HEX: ffffffff MOV rc-absolute-cell rel-here
+ src temp ADD
+ src HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ code-alignment dup bootstrap-cell 8 = 15 9 ? +
+ building get dup pop* push
+ align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
-M: x86 %unbox-float ( dst src -- )
- [ v>operand ] bi@ float-offset [+] MOVSD ;
-
-M: x86 %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek loc>operand MOV ;
-M: x86 %replace swap %peek ;
+M: x86 %replace loc>operand swap MOV ;
: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %copy ( dst src -- ) MOV ;
+
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86 value-structs? t ;
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-M: x86 %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 RET ;
! Alien intrinsics
M: x86 %unbox-byte-array ( dst src -- )
- [ v>operand ] bi@ byte-array-offset [+] LEA ;
+ byte-array-offset [+] LEA ;
M: x86 %unbox-alien ( dst src -- )
- [ v>operand ] bi@ alien-offset [+] MOV ;
+ alien-offset [+] MOV ;
M: x86 %unbox-f ( dst src -- )
- drop v>operand 0 MOV ;
+ drop 0 MOV ;
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
ds-reg 0 MOV
! Object is stored in ds-reg
rs-reg PUSH
- rs-reg swap v>operand MOV
+ rs-reg swap MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
- rs-reg f v>operand CMP
+ rs-reg \ f tag-number CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-fixnum CMP
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
- v>operand ds-reg MOV
+ ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.generator.fixup io.binary kernel
-combinators kernel.private math namespaces make sequences
-words system layouts math.order accessors
-cpu.x86.assembler.syntax ;
+USING: arrays cpu.architecture compiler.constants
+compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system
+layouts math.order accessors cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
+: XCHG ( dst src -- ) OCT: 207 2-operand ;
+
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
swapd
(2-operand) ;
+: MOVZX ( dst src -- )
+ OCT: 266 extended-opcode
+ over register-16? [ BIN: 1 opcode-or ] when
+ swapd
+ (2-operand) ;
+
! Conditional move
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser ;
+USING: kernel words sequences lexer parser fry ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
"register-size" set-word-prop ;
: define-registers ( names size -- )
- >r dup length r> [ define-register ] curry 2each ;
+ '[ _ define-register ] each-index ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
-math.private compiler.generator.fixup compiler.constants vocabs
+math.private compiler.constants vocabs
slots.private words words.private ;
IN: bootstrap.x86
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
-kernel.private math math.private namespaces quotations sequences
-words generic byte-arrays hashtables hashtables.private
-sequences.private sbufs sbufs.private
-vectors vectors.private layouts system strings.private
-slots.private
-compiler.constants
-compiler.intrinsics
-compiler.generator
-compiler.generator.fixup
-compiler.generator.registers ;
+USING: accessors arrays byte-arrays alien.accessors kernel
+kernel.private math memory namespaces make sequences words
+system layouts combinators math.order math.private alien
+alien.c-types slots.private locals fry cpu.architecture
+cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
+compiler.codegen.fixup compiler.constants compiler.intrinsics
+compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.templates compiler.codegen ;
IN: cpu.x86.intrinsics
! Type checks
\ tag [
"in" operand tag-mask get AND
"in" operand %tag-fixnum
-] H{
- { +input+ { { f "in" } } }
- { +output+ { "in" } }
+] T{ template
+ { input { { f "in" } } }
+ { output { "in" } }
} define-intrinsic
! Slots
-: %slot-literal-known-tag ( -- op )
+: %constant-slot ( -- op )
"obj" operand
- "n" get cells
- "obj" get operand-tag - [+] ;
+ "n" literal cells "tag" literal - [+] ;
-: %slot-literal-any-tag ( -- op )
- "obj" operand %untag
- "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
- "obj" operand %untag
+: %computed-slot ( -- op )
"n" operand fixnum>slot@
- "obj" operand "n" operand [+] ;
+ "n" operand "obj" operand ADD
+ "n" operand "tag" literal neg [+] ;
-\ slot {
- ! Slot number is literal and the tag is known
+\ (slot) {
{
- [ "val" operand %slot-literal-known-tag MOV ] H{
- { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "val" } } }
- { +output+ { "val" } }
+ [ "val" operand %constant-slot MOV ] T{ template
+ { input { { f "obj" } { small-slot "n" } { small-slot "tag" } } }
+ { scratch { { f "val" } } }
+ { output { "val" } }
}
}
- ! Slot number is literal
{
- [ "obj" operand %slot-literal-any-tag MOV ] H{
- { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +output+ { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ "obj" operand %slot-any MOV ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +output+ { "obj" } }
- { +clobber+ { "n" } }
+ [ "val" operand %computed-slot MOV ] T{ template
+ { input { { f "obj" } { f "n" } { small-slot "tag" } } }
+ { scratch { { f "val" } } }
+ { output { "val" } }
+ { clobber { "n" } }
}
}
} define-intrinsics
-: generate-write-barrier ( -- )
- #! Mark the card pointed to by vreg.
- "val" get operand-immediate? "obj" get fresh-object? or [
- ! Mark the card
- "obj" operand card-bits SHR
- "cards_offset" f temp-reg v>operand %alien-global
- temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
-
- ! Mark the card deck
- "obj" operand deck-bits card-bits - SHR
- "decks_offset" f temp-reg v>operand %alien-global
- temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
- ] unless ;
-
-\ set-slot {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +clobber+ { "obj" } }
- }
- }
- ! Slot number is literal
+\ (set-slot) {
{
- [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +clobber+ { "obj" } }
+ [ %constant-slot "val" operand MOV ] T{ template
+ { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
}
}
- ! Slot number in a register
{
- [ %slot-any "val" operand MOV generate-write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +clobber+ { "obj" "n" } }
+ [ %computed-slot "val" operand MOV ] T{ template
+ { input { { f "val" } { f "obj" } { f "n" } { small-slot "tag" } } }
+ { clobber { "n" } }
}
}
} define-intrinsics
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
- H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +output+ { "x" } }
+ T{ template
+ { input { { f "x" } { small-tagged "y" } } }
+ { output { "x" } }
} fixnum-op ;
: fixnum-register-op ( op -- pair )
- H{
- { +input+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
+ T{ template
+ { input { { f "x" } { f "y" } } }
+ { output { "x" } }
} fixnum-op ;
: define-fixnum-op ( word op -- )
\ fixnum-bitnot [
"x" operand NOT
"x" operand tag-mask get XOR
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
+] T{ template
+ { input { { f "x" } } }
+ { output { "x" } }
} define-intrinsic
\ fixnum*fast {
{
[
- "x" operand "y" get IMUL2
- ] H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +output+ { "x" } }
+ "x" operand "y" literal IMUL2
+ ] T{ template
+ { input { { f "x" } { small-tagged "y" } } }
+ { output { "x" } }
}
} {
[
"out" operand "x" operand MOV
"out" operand %untag-fixnum
"y" operand "out" operand IMUL2
- ] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
+ ] T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
}
}
} define-intrinsics
-: %untag-fixnums ( seq -- )
- [ %untag-fixnum ] unique-operands ;
-
\ fixnum-shift-fast [
- "x" operand "y" get
+ "x" operand "y" literal
dup 0 < [ neg SAR ] [ SHL ] if
! Mask off low bits
"x" operand %untag
-] H{
- { +input+ { { f "x" } { [ ] "y" } } }
- { +output+ { "x" } }
+] T{ template
+ { input { { f "x" } { small-tagged "y" } } }
+ { output { "x" } }
} define-intrinsic
-: overflow-check ( word -- )
- "end" define-label
- "z" operand "x" operand MOV
- "z" operand "y" operand pick execute
- ! If the previous arithmetic operation overflowed, then we
- ! turn the result into a bignum and leave it in EAX.
- "end" get JNO
- ! There was an overflow. Recompute the original operand.
- { "y" "x" } %untag-fixnums
- "x" operand "y" operand rot execute
- "z" get "x" get %allot-bignum-signed-1
- "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "z" } } }
- { +output+ { "z" } }
- { +clobber+ { "x" "y" } }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
- { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
+ { { f "x" } { small-tagged "y" } } fixnum-jump ;
: fixnum-register-jump ( op -- pair )
{ { f "x" } { f "y" } } fixnum-jump ;
: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
+ [ fixnum-value-jump ] [ fixnum-register-jump ] bi
2array define-if-intrinsics ;
{
- { fixnum< JGE }
- { fixnum<= JG }
- { fixnum> JLE }
- { fixnum>= JL }
- { eq? JNE }
+ { fixnum< JL }
+ { fixnum<= JLE }
+ { fixnum> JG }
+ { fixnum>= JGE }
+ { eq? JE }
} [
first2 define-fixnum-jump
] each
-\ fixnum>bignum [
- "x" operand %untag-fixnum
- "x" get dup %allot-bignum-signed-1
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
\ bignum>fixnum [
"nonzero" define-label
"positive" define-label
"y" operand "x" operand cell [+] MOV
! if the length is 1, its just the sign and nothing else,
! so output 0
- "y" operand 1 v>operand CMP
+ "y" operand 1 tag-fixnum CMP
"nonzero" get JNE
"y" operand 0 MOV
"end" get JMP
"positive" resolve-label
"y" operand 3 SHL
"end" resolve-label
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "y" } } }
- { +clobber+ { "x" } }
- { +output+ { "y" } }
+] T{ template
+ { input { { f "x" } } }
+ { scratch { { f "y" } } }
+ { clobber { "x" } }
+ { output { "y" } }
} define-intrinsic
! User environment
\ getenv [
%userenv "n" operand dup [] MOV
-] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "n" } }
+] T{ template
+ { input { { f "n" } } }
+ { scratch { { f "x" } } }
+ { output { "n" } }
} define-intrinsic
\ setenv [
%userenv "n" operand [] "val" operand MOV
-] H{
- { +input+ { { f "val" } { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +clobber+ { "n" } }
+] T{ template
+ { input { { f "val" } { f "n" } } }
+ { scratch { { f "x" } } }
+ { clobber { "n" } }
} define-intrinsic
-\ (tuple) [
- tuple "layout" get size>> 2 + cells [
- ! Store layout
- "layout" get "scratch" get load-literal
- 1 object@ "scratch" operand MOV
- ! Store tagged ptr in reg
- "tuple" get tuple %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "layout" } } }
- { +scratch+ { { f "tuple" } { f "scratch" } } }
- { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
- array "n" get 2 + cells [
- ! Store length
- 1 object@ "n" operand MOV
- ! Store tagged ptr in reg
- "array" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
- byte-array "n" get 2 cells + [
- ! Store length
- 1 object@ "n" operand MOV
- ! Store tagged ptr in reg
- "array" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ <ratio> [
- ratio 3 cells [
- 1 object@ "numerator" operand MOV
- 2 object@ "denominator" operand MOV
- ! Store tagged ptr in reg
- "ratio" get ratio %store-tagged
- ] %allot
-] H{
- { +input+ { { f "numerator" } { f "denominator" } } }
- { +scratch+ { { f "ratio" } } }
- { +output+ { "ratio" } }
-} define-intrinsic
-
-\ <complex> [
- complex 3 cells [
- 1 object@ "real" operand MOV
- 2 object@ "imaginary" operand MOV
- ! Store tagged ptr in reg
- "complex" get complex %store-tagged
- ] %allot
-] H{
- { +input+ { { f "real" } { f "imaginary" } } }
- { +scratch+ { { f "complex" } } }
- { +output+ { "complex" } }
-} define-intrinsic
+! Alien intrinsics
-\ <wrapper> [
- wrapper 2 cells [
- 1 object@ "obj" operand MOV
- ! Store tagged ptr in reg
- "wrapper" get object %store-tagged
- ] %allot
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "wrapper" } } }
- { +output+ { "wrapper" } }
-} define-intrinsic
+! Sometimes, we need to do stuff with operands which are
+! less than the word size. Instead of teaching the register
+! allocator about the different sized registers, with all
+! the complexity this entails, we just push/pop a register
+! which is guaranteed to be unused (the tempreg)
+: small-reg cell 8 = RDX EDX ? ; inline
+: small-reg-8 DL ; inline
+: small-reg-16 DX ; inline
+: small-reg-32 EDX ; inline
-! Alien intrinsics
-: %alien-accessor ( quot -- )
+: %prepare-alien-accessor ( -- )
"offset" operand %untag-fixnum
- "offset" operand "alien" operand ADD
- "offset" operand [] swap call ; inline
-
-: %alien-integer-get ( quot reg -- )
- small-reg PUSH
- swap %alien-accessor
- "value" operand small-reg MOV
- "value" operand %tag-fixnum
- small-reg POP ; inline
+ "offset" operand "alien" operand ADD ;
+
+:: (%alien-integer-get) ( reg quot -- )
+ reg "offset" operand [] MOV
+ "value" operand reg quot call ; inline
+
+: %alien-integer-get ( reg quot -- )
+ %prepare-alien-accessor
+ "value" operand small-reg = [
+ (%alien-integer-get)
+ ] [
+ small-reg PUSH
+ (%alien-integer-get)
+ small-reg POP
+ ] if
+ "value" operand %tag-fixnum ; inline
: alien-integer-get-template
- H{
- { +input+ {
+ T{ template
+ { input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +scratch+ { { f "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
+ { scratch { { f "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
} ;
-: define-getter ( word quot reg -- )
- [ %alien-integer-get ] 2curry
+: define-getter ( word reg quot -- )
+ '[ _ _ %alien-integer-get ]
alien-integer-get-template
define-intrinsic ;
: define-unsigned-getter ( word reg -- )
- [ small-reg dup XOR MOV ] swap define-getter ;
+ [ MOVZX ] define-getter ;
: define-signed-getter ( word reg -- )
- [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
-
-: %alien-integer-set ( quot reg -- )
- small-reg PUSH
- small-reg "value" operand MOV
- small-reg %untag-fixnum
- swap %alien-accessor
- small-reg POP ; inline
+ [ MOVSX ] define-getter ;
+
+: %alien-integer-set ( reg -- )
+ "value" operand "offset" operand = [
+ "value" operand %untag-fixnum
+ ] unless
+ %prepare-alien-accessor
+ small-reg "offset" operand = [
+ "value" operand "offset" operand XCHG
+ "value" operand [] swap MOV
+ ] [
+ small-reg PUSH
+ small-reg "value" operand MOV
+ "offset" operand [] swap MOV
+ small-reg POP
+ ] if ; inline
: alien-integer-set-template
- H{
- { +input+ {
+ T{ template
+ { input {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +clobber+ { "value" "offset" } }
+ { clobber { "value" "offset" } }
} ;
: define-setter ( word reg -- )
- [ swap MOV ] swap
- [ %alien-integer-set ] 2curry
+ '[ _ %alien-integer-set ]
alien-integer-set-template
define-intrinsic ;
\ set-alien-signed-2 small-reg-16 define-setter
\ alien-cell [
- "value" operand [ MOV ] %alien-accessor
-] H{
- { +input+ {
+ %prepare-alien-accessor
+ "value" operand "offset" operand [] MOV
+] T{ template
+ { input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +scratch+ { { unboxed-alien "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
+ { scratch { { unboxed-alien "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
} define-intrinsic
\ set-alien-cell [
- "value" operand [ swap MOV ] %alien-accessor
-] H{
- { +input+ {
+ %prepare-alien-accessor
+ "offset" operand [] "value" operand MOV
+] T{ template
+ { input {
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +clobber+ { "offset" } }
+ { clobber { "offset" } }
} define-intrinsic
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics generic kernel
+USING: alien alien.accessors arrays generic kernel
kernel.private math math.private memory namespaces sequences
-words compiler.generator compiler.generator.registers
-cpu.architecture math.floats.private layouts quotations ;
+words math.floats.private layouts quotations locals fry
+system compiler.constants compiler.codegen compiler.cfg.templates
+compiler.cfg.registers compiler.cfg.builder cpu.architecture
+cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
IN: cpu.x86.sse2
+M: x86 %copy-float MOVSD ;
+
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float float temp %allot
+ dst 8 float tag-number - [+] src MOVSD ;
+
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
+
: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap suffix H{
- { +input+ { { float "x" } { float "y" } } }
- { +output+ { "x" } }
+ [ "x" operand "y" operand ] swap suffix T{ template
+ { input { { float "x" } { float "y" } } }
+ { output { "x" } }
} define-intrinsic ;
{
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< JAE }
- { float<= JA }
- { float> JBE }
- { float>= JB }
- { float= JNE }
+ { float< JB }
+ { float<= JBE }
+ { float> JA }
+ { float>= JAE }
+ { float= JE }
} [
first2 define-float-jump
] each
\ float>fixnum [
"out" operand "in" operand CVTTSD2SI
"out" operand tag-bits get SHL
-] H{
- { +input+ { { float "in" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
+] T{ template
+ { input { { float "in" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
} define-intrinsic
\ fixnum>float [
"in" operand %untag-fixnum
"out" operand "in" operand CVTSI2SD
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { float "out" } } }
- { +output+ { "out" } }
- { +clobber+ { "in" } }
+] T{ template
+ { input { { f "in" } } }
+ { scratch { { float "out" } } }
+ { output { "out" } }
+ { clobber { "in" } }
} define-intrinsic
: alien-float-get-template
- H{
- { +input+ {
+ T{ template
+ { input {
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +scratch+ { { float "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
+ { scratch { { float "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
} ;
: alien-float-set-template
- H{
- { +input+ {
+ T{ template
+ { input {
{ float "value" float }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
- { +clobber+ { "offset" } }
+ { clobber { "offset" } }
} ;
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
- [ "value" operand swap %alien-accessor ] curry
- alien-float-set-template
- define-intrinsic
- [ "value" operand swap %alien-accessor ] curry
+: define-float-getter ( word get-quot -- )
+ '[
+ %prepare-alien-accessor
+ "value" operand "offset" operand [] @
+ ]
alien-float-get-template
define-intrinsic ;
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
+: define-float-setter ( word set-quot -- )
+ '[
+ %prepare-alien-accessor
+ "offset" operand [] "value" operand @
+ ]
+ alien-float-set-template
+ define-intrinsic ;
+
+\ alien-double [ MOVSD ] define-float-getter
+\ set-alien-double [ MOVSD ] define-float-setter
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
+\ alien-float [ dupd MOVSS dup CVTSS2SD ] define-float-getter
+\ set-alien-float [ dup dup CVTSD2SS MOVSS ] define-float-setter
M: float-array >pprint-sequence ;
M: float-array pprint* pprint-object ;
+! Rice
USING: hints math.vectors arrays ;
HINTS: vneg { float-array } { array } ;
HINTS: norm-sq { float-array } { array } ;
HINTS: norm { float-array } { array } ;
HINTS: normalize { float-array } { array } ;
+
+! More rice. Experimental, currently causes a slowdown in raytracer
+! for some odd reason.
+
+USING: words classes.algebra compiler.tree.propagation.info ;
+
+{ v+ v- v* v/ vmax vmin } [
+ [
+ [ class>> float-array class<= ] both?
+ float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ n*v n/v } [
+ [
+ nip class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ v*n v/n } [
+ [
+ drop class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+{ vneg normalize } [
+ [
+ class>> float-array class<= float-array object ? <class-info>
+ ] "outputs" set-word-prop
+] each
+
+\ norm-sq [
+ class>> float-array class<= float object ? <class-info>
+] "outputs" set-word-prop
+
+\ v. [
+ [ class>> float-array class<= ] both?
+ float object ? <class-info>
+] "outputs" set-word-prop
: infer-branches ( branches -- input children data )
[ pop-d ] dip
[ infer-branch ] map
- [ stack-visitor branch-variable ] keep ;
+ [ stack-visitor branch-variable ] keep ; inline
: (infer-if) ( branches -- )
- infer-branches [ first2 #if, ] dip compute-phi-function ;
+ infer-branches
+ [ first2 #if, ] dip compute-phi-function ;
: infer-if ( -- )
2 consume-d
: infer-dispatch ( -- )
pop-literal nip [ <literal> ] map
- infer-branches [ #dispatch, ] dip compute-phi-function ;
+ infer-branches
+ [ #dispatch, ] dip compute-phi-function ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces make
-qualified system math compiler.generator.fixup
+qualified system math compiler.codegen.fixup
io.encodings.ascii accessors generic tr ;
IN: tools.disassembler
"type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
- [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
+ \ hi-tag def>> num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
<PRIVATE
-: hi-tag ( obj -- n ) 0 slot ; inline
-
: declare ( spec -- ) drop ;
+: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
+
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
+++ /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
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words ;
-IN: compiler.backend
-
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
-! A pseudo-register class for parameters spilled on the stack
-SINGLETON: stack-params
-
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
-
-! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( register-class -- regs )
-
-GENERIC: param-reg ( n register-class -- reg )
-
-M: object param-reg param-regs nth ;
-
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj reg -- )
-
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( frame-size -- n )
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-! Call another word
-HOOK: %call cpu ( word -- )
-
-! Local jump for branches
-HOOK: %jump-label cpu ( label -- )
-
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label reg -- )
-
-! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label reg -- )
-
-HOOK: %dispatch cpu ( -- )
-
-HOOK: %dispatch-label cpu ( word -- )
-
-! Return to caller
-HOOK: %return cpu ( -- )
-
-! Change datastack height
-HOOK: %inc-d cpu ( n -- )
-
-! Change callstack height
-HOOK: %inc-r cpu ( n -- )
-
-! Load stack into vreg
-HOOK: %peek cpu ( reg loc -- )
-
-! Store vreg to stack
-HOOK: %replace cpu ( reg loc -- )
-
-! Copy values between vregs
-HOOK: %copy cpu ( dst src -- )
-HOOK: %copy-float cpu ( dst src -- )
-
-! Box and unbox floats
-HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
-
-! FFI stuff
-
-! Is this integer small enough to appear in value template
-! slots?
-HOOK: small-enough? cpu ( n -- ? )
-
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( heap-size -- ? )
-
-! Do we pass explode value structs?
-HOOK: value-structs? cpu ( -- ? )
-
-! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
-
-HOOK: %prepare-unbox cpu ( -- )
-
-HOOK: %unbox cpu ( n reg-class func -- )
-
-HOOK: %unbox-long-long cpu ( n func -- )
-
-HOOK: %unbox-small-struct cpu ( c-type -- )
-
-HOOK: %unbox-large-struct cpu ( n c-type -- )
-
-HOOK: %box cpu ( n reg-class func -- )
-
-HOOK: %box-long-long cpu ( n func -- )
-
-HOOK: %prepare-box-struct cpu ( size -- )
-
-HOOK: %box-small-struct cpu ( c-type -- )
-
-HOOK: %box-large-struct cpu ( n c-type -- )
-
-GENERIC: %save-param-reg ( stack reg reg-class -- )
-
-GENERIC: %load-param-reg ( stack reg reg-class -- )
-
-HOOK: %prepare-alien-invoke cpu ( -- )
-
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
-
-HOOK: %alien-invoke cpu ( function library -- )
-
-HOOK: %cleanup cpu ( alien-node -- )
-
-HOOK: %alien-callback cpu ( quot -- )
-
-HOOK: %callback-value cpu ( ctype -- )
-
-! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
-
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
-
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
-
-M: object load-literal load-indirect ;
-
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
-
-: if-small-struct ( n size true false -- ? )
- [ over not over struct-small-enough? and ] 2dip
- [ [ nip ] prepose ] dip if ;
- inline
-
-: %unbox-struct ( n c-type -- )
- [
- %unbox-small-struct
- ] [
- %unbox-large-struct
- ] if-small-struct ;
-
-: %box-struct ( n c-type -- )
- [
- %box-small-struct
- ] [
- %box-large-struct
- ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src -- )
-
-! Allocation
-HOOK: %allot cpu ( dst size type tag temp -- )
-
-HOOK: %write-barrier cpu ( src temp -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel kernel.private math
-namespaces sequences stack-checker.known-words system layouts
-combinators command-line io vocabs.loader accessors init
-compiler compiler.units compiler.constants compiler.codegen
-compiler.cfg.builder compiler.alien compiler.codegen.fixup
-cpu.x86 compiler.backend compiler.backend.x86 ;
-IN: compiler.backend.x86.32
-
-! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned, and we do
-! this on all platforms, sacrificing some stack space for
-! code simplicity.
-
-M: x86.32 machine-registers
- {
- { int-regs { EAX ECX EDX EBP EBX } }
- { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
- } ;
-
-M: x86.32 ds-reg ESI ;
-M: x86.32 rs-reg EDI ;
-M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
-M: x86.32 temp-reg-1 EAX ;
-M: x86.32 temp-reg-2 ECX ;
-
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
-
-M: x86.32 struct-small-enough? ( size -- ? )
- heap-size { 1 2 4 8 } member?
- os { linux netbsd solaris } member? not and ;
-
-! On x86, parameters are never passed in registers.
-M: int-regs return-reg drop EAX ;
-M: int-regs param-regs drop { } ;
-M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
- return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
-
-M: float-regs param-regs drop { } ;
-
-: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
-
-M: float-regs push-return-reg
- stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
-
-: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-
-: load/store-float-return ( n reg-class -- op size )
- [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
-
-: align-sub ( n -- )
- dup 16 align swap - ESP swap SUB ;
-
-: align-add ( n -- )
- 16 align ESP swap ADD ;
-
-: with-aligned-stack ( n quot -- )
- swap dup align-sub slip align-add ; inline
-
-M: x86.32 fixnum>slot@ 1 SHR ;
-
-M: x86.32 prepare-division CDQ ;
-
-M: x86.32 load-indirect
- 0 [] MOV rc-absolute-cell rel-literal ;
-
-M: object %load-param-reg 3drop ;
-
-M: object %save-param-reg 3drop ;
-
-: box@ ( n reg-class -- stack@ )
- #! Used for callbacks; we want to box the values given to
- #! us by the C function caller. Computes stack location of
- #! nth parameter; note that we must go back one more stack
- #! frame, since %box sets one up to call the one-arg boxer
- #! function. The size of this stack frame so far depends on
- #! the reg-class of the boxer's arg.
- reg-size neg + stack-frame* + 20 + ;
-
-: (%box) ( n reg-class -- )
- #! If n is f, push the return register onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n] on the stack; we are boxing a
- #! parameter being passed to a callback from C.
- over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
- push-return-reg ;
-
-M: x86.32 %box ( n reg-class func -- )
- over reg-size [
- >r (%box) r> f %alien-invoke
- ] with-aligned-stack ;
-
-: (%box-long-long) ( n -- )
- #! If n is f, push the return registers onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
- #! boxing a parameter being passed to a callback from C.
- [
- int-regs box@
- EDX over stack@ MOV
- EAX swap cell - stack@ MOV
- ] when*
- EDX PUSH
- EAX PUSH ;
-
-M: x86.32 %box-long-long ( n func -- )
- 8 [
- [ (%box-long-long) ] [ f %alien-invoke ] bi*
- ] with-aligned-stack ;
-
-: struct-return@ ( size n -- n )
- [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
- ! Compute destination address
- heap-size
- [ swap struct-return@ ] keep
- ECX ESP roll [+] LEA
- 8 [
- ! Push struct size
- PUSH
- ! Push destination address
- ECX PUSH
- ! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-box-struct ( size -- )
- ! Compute target address for value struct return
- EAX ESP rot f struct-return@ [+] LEA
- ! Store it as the first parameter
- ESP [] EAX MOV ;
-
-M: x86.32 %box-small-struct ( c-type -- )
- #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 [
- heap-size PUSH
- EDX PUSH
- EAX PUSH
- "box_small_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-unbox ( -- )
- #! Move top of data stack to EAX.
- EAX ESI [] MOV
- ESI 4 SUB ;
-
-: (%unbox) ( func -- )
- 4 [
- ! Push parameter
- EAX PUSH
- ! Call the unboxer
- f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %unbox ( n reg-class func -- )
- #! The value being unboxed must already be in EAX.
- #! If n is f, we're unboxing a return value about to be
- #! returned by the callback. Otherwise, we're unboxing
- #! a parameter to a C function about to be called.
- (%unbox)
- ! Store the return value on the C stack
- over [ store-return-reg ] [ 2drop ] if ;
-
-M: x86.32 %unbox-long-long ( n func -- )
- (%unbox)
- ! Store the return value on the C stack
- [
- dup stack@ EAX MOV
- cell + stack@ EDX MOV
- ] when* ;
-
-: %unbox-struct-1 ( -- )
- #! Alien must be in EAX.
- 4 [
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
-
-: %unbox-struct-2 ( -- )
- #! Alien must be in EAX.
- 4 [
- EAX PUSH
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV
- ] with-aligned-stack ;
-
-M: x86 %unbox-small-struct ( size -- )
- #! Alien must be in EAX.
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- } case ;
-
-M: x86.32 %unbox-large-struct ( n c-type -- )
- #! Alien must be in EAX.
- heap-size
- ! Compute destination address
- ECX ESP roll [+] LEA
- 12 [
- ! Push struct size
- PUSH
- ! Push destination address
- ECX PUSH
- ! Push source address
- EAX PUSH
- ! Copy the struct to the stack
- "to_value_struct" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
- cell temp@ EAX MOV ;
-
-M: x86.32 %alien-indirect ( -- )
- cell temp@ CALL ;
-
-M: x86.32 %alien-callback ( quot -- )
- 4 [
- EAX load-indirect
- EAX PUSH
- "c_to_factor" f %alien-invoke
- ] with-aligned-stack ;
-
-M: x86.32 %callback-value ( ctype -- )
- ! Align C stack
- ESP 12 SUB
- ! Save top of data stack
- %prepare-unbox
- EAX PUSH
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Place top of data stack in EAX
- EAX POP
- ! Restore C stack
- ESP 12 ADD
- ! Unbox EAX
- unbox-return ;
-
-M: x86.32 %cleanup ( alien-node -- )
- #! a) If we just called an stdcall function in Windows, it
- #! cleaned up the stack frame for us. But we don't want that
- #! so we 'undo' the cleanup since we do that in %epilogue.
- #! b) If we just called a function returning a struct, we
- #! have to fix ESP.
- {
- {
- [ dup abi>> "stdcall" = ]
- [ alien-stack-frame ESP swap SUB ]
- } {
- [ dup return>> large-struct? ]
- [ drop EAX PUSH ]
- }
- [ drop ]
- } cond ;
-
-M: x86.32 %unwind ( n -- ) RET ;
-
-os windows? [
- cell "longlong" c-type (>>align)
- cell "ulonglong" c-type (>>align)
- 4 "double" c-type (>>align)
-] unless
-
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
-
-<<
-
-\ (sse2?) [
- { EAX EBX ECX EDX } [ PUSH ] each
- EAX 1 MOV
- CPUID
- EDX 26 SHR
- EDX 1 AND
- { EAX EBX ECX EDX } [ POP ] each
- JE
-] { } define-if-intrinsic
-
-\ (sse2?) { } { object } define-primitive
-
->>
-
-: sse2? ( -- ? ) (sse2?) ;
-
-"-no-sse2" cli-args member? [
- "Checking if your CPU supports SSE2..." print flush
- [ optimized-recompile-hook ] recompile-hook [
- [ sse2? ] compile-call
- ] with-variable
- [
- " - yes" print
- "compiler.backend.x86.sse2" require
- [
- sse2? [
- "This image was built to use SSE2, which your CPU does not support." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] unless
- ] "compiler.backend.x86" add-init-hook
- ] [
- " - no" print
- ] if
-] unless
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays kernel kernel.private math
-namespaces make sequences system layouts alien alien.accessors
-alien.structs slots splitting assocs combinators
-cpu.x86 compiler.codegen compiler.constants
-compiler.codegen.fixup compiler.cfg.registers compiler.backend
-compiler.backend.x86 compiler.backend.x86.sse2 ;
-IN: compiler.backend.x86.64
-
-M: x86.64 machine-registers
- {
- { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
- { double-float-regs {
- XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
- XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
- } }
- } ;
-
-M: x86.64 ds-reg R14 ;
-M: x86.64 rs-reg R15 ;
-M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
-M: x86.64 temp-reg-1 RAX ;
-M: x86.64 temp-reg-2 RCX ;
-
-M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
-M: float-regs return-reg drop XMM0 ;
-
-M: float-regs param-regs
- drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
-M: x86.64 fixnum>slot@ drop ;
-
-M: x86.64 prepare-division CQO ;
-
-M: x86.64 load-indirect ( literal reg -- )
- 0 [] MOV rc-relative rel-literal ;
-
-M: stack-params %load-param-reg
- drop
- >r R11 swap stack@ MOV
- r> stack@ R11 MOV ;
-
-M: stack-params %save-param-reg
- >r stack-frame* + cell + swap r> %load-param-reg ;
-
-: with-return-regs ( quot -- )
- [
- V{ RDX RAX } clone int-regs set
- V{ XMM1 XMM0 } clone float-regs set
- call
- ] with-scope ; inline
-
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
- fields>> [
- [ type>> ] [ offset>> ] bi 2array
- ] map ;
-
-: split-struct ( pairs -- seq )
- [
- [ 8 mod zero? [ t , ] when , ] assoc-each
- ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
- struct-types&offset split-struct [
- [ c-type c-type-reg-class ] map
- int-regs swap member? "void*" "double" ? c-type
- ] map ;
-
-: flatten-large-struct ( c-type -- seq )
- heap-size cell align
- cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
- dup heap-size 16 > [
- flatten-large-struct
- ] [
- flatten-small-struct
- ] if ;
-
-M: x86.64 %prepare-unbox ( -- )
- ! First parameter is top of stack
- RDI R14 [] MOV
- R14 cell SUB ;
-
-M: x86.64 %unbox ( n reg-class func -- )
- ! Call the unboxer
- f %alien-invoke
- ! Store the return value on the C stack
- over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: x86.64 %unbox-long-long ( n func -- )
- int-regs swap %unbox ;
-
-: %unbox-struct-field ( c-type i -- )
- ! Alien must be in RDI.
- RDI swap cells [+] swap reg-class>> {
- { int-regs [ int-regs get pop swap MOV ] }
- { double-float-regs [ float-regs get pop swap MOVSD ] }
- } case ;
-
-M: x86.64 %unbox-small-struct ( c-type -- )
- ! Alien must be in RDI.
- "alien_offset" f %alien-invoke
- ! Move alien_offset() return value to RDI so that we don't
- ! clobber it.
- RDI RAX MOV
- [
- flatten-small-struct [ %unbox-struct-field ] each-index
- ] with-return-regs ;
-
-M: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in RDI
- heap-size
- ! Load destination address
- RSI RSP roll [+] LEA
- ! Load structure size
- RDX swap MOV
- ! Copy the struct to the C stack
- "to_value_struct" f %alien-invoke ;
-
-: load-return-value ( reg-class -- )
- 0 over param-reg swap return-reg
- 2dup eq? [ 2drop ] [ MOV ] if ;
-
-M: x86.64 %box ( n reg-class func -- )
- rot [
- rot [ 0 swap param-reg ] keep %load-param-reg
- ] [
- swap load-return-value
- ] if*
- f %alien-invoke ;
-
-M: x86.64 %box-long-long ( n func -- )
- int-regs swap %box ;
-
-M: x86.64 struct-small-enough? ( size -- ? )
- heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
-
-: %box-struct-field ( c-type i -- )
- box-struct-field@ swap reg-class>> {
- { int-regs [ int-regs get pop MOV ] }
- { double-float-regs [ float-regs get pop MOVSD ] }
- } case ;
-
-M: x86.64 %box-small-struct ( c-type -- )
- #! Box a <= 16-byte struct.
- [
- [ flatten-small-struct [ %box-struct-field ] each-index ]
- [ RDX swap heap-size MOV ] bi
- RDI 0 box-struct-field@ MOV
- RSI 1 box-struct-field@ MOV
- "box_small_struct" f %alien-invoke
- ] with-return-regs ;
-
-: struct-return@ ( size n -- n )
- [ ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.64 %box-large-struct ( n c-type -- )
- ! Struct size is parameter 2
- heap-size
- RSI over MOV
- ! Compute destination address
- swap struct-return@ RDI RSP rot [+] LEA
- ! Copy the struct from the C stack
- "box_value_struct" f %alien-invoke ;
-
-M: x86.64 %prepare-box-struct ( size -- )
- ! Compute target address for value struct return
- RAX RSP rot f struct-return@ [+] LEA
- RSP 0 [+] RAX MOV ;
-
-M: x86.64 %prepare-var-args RAX RAX XOR ;
-
-M: x86.64 %alien-global
- [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
-M: x86.64 %alien-invoke
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 CALL ;
-
-M: x86.64 %prepare-alien-indirect ( -- )
- "unbox_alien" f %alien-invoke
- cell temp@ RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
- cell temp@ CALL ;
-
-M: x86.64 %alien-callback ( quot -- )
- RDI load-indirect "c_to_factor" f %alien-invoke ;
-
-M: x86.64 %callback-value ( ctype -- )
- ! Save top of data stack
- %prepare-unbox
- ! Put former top of data stack in RDI
- cell temp@ RDI MOV
- ! Restore data/call/retain stacks
- "unnest_stacks" f %alien-invoke
- ! Put former top of data stack in RDI
- RDI cell temp@ MOV
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
-M: x86.64 %cleanup ( alien-node -- ) drop ;
-
-M: x86.64 %unwind ( n -- ) drop 0 RET ;
-
-USE: cpu.x86.intrinsics
-
-! On 64-bit systems, the result of reading 4 bytes from memory
-! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
-
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays generic kernel system
-kernel.private math math.private memory namespaces sequences
-words math.floats.private layouts quotations locals cpu.x86
-compiler.codegen compiler.cfg.templates compiler.cfg.builder
-compiler.cfg.registers compiler.constants compiler.backend
-compiler.backend.x86 ;
-IN: compiler.backend.x86.sse2
-
-M:: x86 %box-float ( dst src temp -- )
- #! Only called by pentium4 backend, uses SSE2 instruction
- dst 16 float float temp %allot
- dst 8 float tag-number - [+] src MOVSD ;
-
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
-
-: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap suffix T{ template
- { input { { float "x" } { float "y" } } }
- { output { "x" } }
- } define-intrinsic ;
-
-{
- { float+ ADDSD }
- { float- SUBSD }
- { float* MULSD }
- { float/f DIVSD }
-} [
- first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap suffix
- { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
- { float< JAE }
- { float<= JA }
- { float> JBE }
- { float>= JB }
- { float= JNE }
-} [
- first2 define-float-jump
-] each
-
-\ float>fixnum [
- "out" operand "in" operand CVTTSD2SI
- "out" operand tag-bits get SHL
-] T{ template
- { input { { float "in" } } }
- { scratch { { f "out" } } }
- { output { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
- "in" operand %untag-fixnum
- "out" operand "in" operand CVTSI2SD
-] T{ template
- { input { { f "in" } } }
- { scratch { { float "out" } } }
- { output { "out" } }
- { clobber { "in" } }
-} define-intrinsic
-
-: alien-float-get-template
- T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { float "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
- } ;
-
-: alien-float-set-template
- T{ template
- { input {
- { float "value" float }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "offset" } }
- } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
- [ "value" operand swap %alien-accessor ] curry
- alien-float-set-template
- define-intrinsic
- [ "value" operand swap %alien-accessor ] curry
- alien-float-get-template
- define-intrinsic ;
-
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
-
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays alien.accessors
-compiler.backend kernel kernel.private math memory namespaces
-make sequences words system layouts combinators math.order
-math.private alien alien.c-types slots.private cpu.x86
-cpu.x86.private locals compiler.backend compiler.codegen.fixup
-compiler.constants compiler.intrinsics compiler.cfg.builder
-compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.templates compiler.codegen ;
-IN: compiler.backend.x86
-
-HOOK: ds-reg cpu ( -- reg )
-HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
-
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-GENERIC: loc>operand ( loc -- operand )
-
-M: ds-loc loc>operand n>> ds-reg reg-stack ;
-M: rs-loc loc>operand n>> rs-reg reg-stack ;
-
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
-
-! Only used by inline allocation
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
-
-HOOK: fixnum>slot@ cpu ( op -- )
-
-HOOK: prepare-division cpu ( -- )
-
-M: f load-literal
- \ f tag-number MOV drop ;
-
-M: fixnum load-literal
- swap tag-fixnum MOV ;
-
-M: x86 stack-frame ( n -- i )
- 3 cells + 16 align cell - ;
-
-: factor-area-size ( -- n ) 4 cells ;
-
-M: x86 %prologue ( n -- )
- temp-reg-1 0 MOV rc-absolute-cell rel-this
- dup cell + PUSH
- temp-reg-1 PUSH
- stack-reg swap 2 cells - SUB ;
-
-M: x86 %epilogue ( n -- )
- stack-reg swap ADD ;
-
-HOOK: %alien-global cpu ( symbol dll register -- )
-
-M: x86 %prepare-alien-invoke
- #! Save Factor stack pointers in case the C code calls a
- #! callback which does a GC, which must reliably trace
- #! all roots.
- "stack_chain" f temp-reg-1 %alien-global
- temp-reg-1 [] stack-reg MOV
- temp-reg-1 [] cell SUB
- temp-reg-1 2 cells [+] ds-reg MOV
- temp-reg-1 3 cells [+] rs-reg MOV ;
-
-M: x86 %call ( label -- ) CALL ;
-
-M: x86 %jump-label ( label -- ) JMP ;
-
-M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
-
-M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
-
-: code-alignment ( -- n )
- building get length dup cell align swap - ;
-
-: align-code ( n -- )
- 0 <repetition> % ;
-
-M:: x86 %dispatch ( src temp -- )
- ! Load jump table base. We use a temporary register
- ! since on AMD64 we have to load a 64-bit immediate. On
- ! x86, this is redundant.
- ! Untag and multiply to get a jump table offset
- src fixnum>slot@
- ! Add jump table base
- temp HEX: ffffffff MOV rc-absolute-cell rel-here
- src temp ADD
- src HEX: 7f [+] JMP
- ! Fix up the displacement above
- code-alignment dup bootstrap-cell 8 = 15 9 ? +
- building get dup pop* push
- align-code ;
-
-M: x86 %dispatch-label ( word -- )
- 0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %peek loc>operand MOV ;
-
-M: x86 %replace loc>operand swap MOV ;
-
-: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-
-M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
-M: x86 value-structs? t ;
-
-M: x86 small-enough? ( n -- ? )
- HEX: -80000000 HEX: 7fffffff between? ;
-
-: %untag ( reg -- ) tag-mask get bitnot AND ;
-
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
-
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
-M: x86 %return ( -- ) 0 %unwind ;
-
-! Alien intrinsics
-M: x86 %unbox-byte-array ( dst src -- )
- byte-array-offset [+] LEA ;
-
-M: x86 %unbox-alien ( dst src -- )
- alien-offset [+] MOV ;
-
-M: x86 %unbox-f ( dst src -- )
- drop 0 MOV ;
-
-M: x86 %unbox-any-c-ptr ( dst src -- )
- { "is-byte-array" "end" "start" } [ define-label ] each
- ! Address is computed in ds-reg
- ds-reg PUSH
- ds-reg 0 MOV
- ! Object is stored in ds-reg
- rs-reg PUSH
- rs-reg swap MOV
- ! We come back here with displaced aliens
- "start" resolve-label
- ! Is the object f?
- rs-reg \ f tag-number CMP
- "end" get JE
- ! Is the object an alien?
- rs-reg header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- ds-reg rs-reg alien-offset [+] ADD
- ! Now recurse on the underlying alien
- rs-reg rs-reg underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- ds-reg rs-reg ADD
- ! Add an offset to start of byte array's data
- ds-reg byte-array-offset ADD
- "end" resolve-label
- ! Done, store address in destination register
- ds-reg MOV
- ! Restore rs-reg
- rs-reg POP
- ! Restore ds-reg
- ds-reg POP ;
-
-M:: x86 %write-barrier ( src temp -- )
- #! Mark the card pointed to by vreg.
- ! Mark the card
- src card-bits SHR
- "cards_offset" f temp %alien-global
- temp temp [+] card-mark <byte> MOV
-
- ! Mark the card deck
- temp deck-bits card-bits - SHR
- "decks_offset" f temp %alien-global
- temp temp [+] card-mark <byte> MOV ;
-
-: load-zone-ptr ( reg -- )
- #! Load pointer to start of zone array
- 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( temp -- )
- [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
-
-: inc-allot-ptr ( n temp -- )
- [ POP ] [ cell [+] swap 8 align ADD ] bi ;
-
-: store-header ( temp type -- )
- [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
-
-: store-tagged ( dst temp tag -- )
- dupd tag-number OR MOV ;
-
-M:: x86 %allot ( dst size type tag temp -- )
- temp load-allot-ptr
- temp type store-header
- temp size inc-allot-ptr
- dst temp store-tagged ;
-
-M: x86 %gc ( -- )
- "end" define-label
- temp-reg-1 load-zone-ptr
- temp-reg-2 temp-reg-1 cell [+] MOV
- temp-reg-2 1024 ADD
- temp-reg-1 temp-reg-1 3 cells [+] MOV
- temp-reg-2 temp-reg-1 CMP
- "end" get JLE
- %prepare-alien-invoke
- "minor_gc" f %alien-invoke
- "end" resolve-label ;
-
-: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
-
-:: %allot-bignum-signed-1 ( dst src temp -- )
- #! on entry, inreg is a signed 32-bit quantity
- #! exits with tagged ptr to bignum in outreg
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
- [
- { "end" "nonzero" "positive" "store" } [ define-label ] each
- src 0 CMP ! is it zero?
- "nonzero" get JNE
- ! Use cached zero value
- 0 >bignum dst load-indirect
- "end" get JMP
- "nonzero" resolve-label
- ! Allocate a bignum
- dst 4 cells bignum bignum temp %allot
- ! Write length
- dst 1 bignum@ 2 MOV
- ! Test sign
- src 0 CMP
- "positive" get JGE
- dst 2 bignum@ 1 MOV ! negative sign
- src NEG
- "store" get JMP
- "positive" resolve-label
- dst 2 bignum@ 0 MOV ! positive sign
- "store" resolve-label
- dst 3 bignum@ src MOV
- "end" resolve-label
- ] with-scope ;
-
-: alien@ ( reg n -- op ) cells object tag-number - [+] ;
-
-M:: x86 %box-alien ( dst src temp -- )
- [
- { "end" "f" } [ define-label ] each
- src 0 CMP
- "f" get JE
- dst 4 cells alien object temp %allot
- dst 1 alien@ \ f tag-number MOV
- dst 2 alien@ \ f tag-number MOV
- ! Store src in alien-offset slot
- dst 3 alien@ src MOV
- "end" get JMP
- "f" resolve-label
- \ f tag-number MOV
- "end" resolve-label
- ] with-scope ;
-
-! Type checks
-\ tag [
- "in" operand tag-mask get AND
- "in" operand %tag-fixnum
-] T{ template
- { input { { f "in" } } }
- { output { "in" } }
-} define-intrinsic
-
-! Slots
-: %slot-literal-known-tag ( -- op )
- "obj" operand
- "n" get cells
- "obj" operand-tag - [+] ;
-
-: %slot-literal-any-tag ( -- op )
- "obj" operand %untag
- "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
- "obj" operand %untag
- "n" operand fixnum>slot@
- "obj" operand "n" operand [+] ;
-
-\ slot {
- ! Slot number is literal and the tag is known
- {
- [ "val" operand %slot-literal-known-tag MOV ] T{ template
- { input { { f "obj" known-tag } { small-slot "n" } } }
- { scratch { { f "val" } } }
- { output { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ "obj" operand %slot-literal-any-tag MOV ] T{ template
- { input { { f "obj" } { small-slot "n" } } }
- { output { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ "obj" operand %slot-any MOV ] T{ template
- { input { { f "obj" } { f "n" } } }
- { output { "obj" } }
- { clobber { "n" } }
- }
- }
-} define-intrinsics
-
-\ (set-slot) {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" } { small-slot "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any "val" operand MOV ] T{ template
- { input { { f "val" } { f "obj" } { f "n" } } }
- { scratch { { f "scratch" } } }
- { clobber { "obj" "n" } }
- }
- }
-} define-intrinsics
-
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
-! Fixnums
-: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap suffix r> 2array ;
-
-: fixnum-value-op ( op -- pair )
- T{ template
- { input { { f "x" } { small-tagged "y" } } }
- { output { "x" } }
- } fixnum-op ;
-
-: fixnum-register-op ( op -- pair )
- T{ template
- { input { { f "x" } { f "y" } } }
- { output { "x" } }
- } fixnum-op ;
-
-: define-fixnum-op ( word op -- )
- [ fixnum-value-op ] keep fixnum-register-op
- 2array define-intrinsics ;
-
-{
- { fixnum+fast ADD }
- { fixnum-fast SUB }
- { fixnum-bitand AND }
- { fixnum-bitor OR }
- { fixnum-bitxor XOR }
-} [
- first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
- "x" operand NOT
- "x" operand tag-mask get XOR
-] T{ template
- { input { { f "x" } } }
- { output { "x" } }
-} define-intrinsic
-
-\ fixnum*fast {
- {
- [
- "x" operand "y" get IMUL2
- ] T{ template
- { input { { f "x" } { [ small-tagged? ] "y" } } }
- { output { "x" } }
- }
- } {
- [
- "out" operand "x" operand MOV
- "out" operand %untag-fixnum
- "y" operand "out" operand IMUL2
- ] T{ template
- { input { { f "x" } { f "y" } } }
- { scratch { { f "out" } } }
- { output { "out" } }
- }
- }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
- [ %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast [
- "x" operand "y" get
- dup 0 < [ neg SAR ] [ SHL ] if
- ! Mask off low bits
- "x" operand %untag
-] T{ template
- { input { { f "x" } { [ ] "y" } } }
- { output { "x" } }
-} define-intrinsic
-
-: overflow-check ( word -- )
- "end" define-label
- "z" operand "x" operand MOV
- "z" operand "y" operand pick execute
- ! If the previous arithmetic operation overflowed, then we
- ! turn the result into a bignum and leave it in EAX.
- "end" get JNO
- ! There was an overflow. Recompute the original operand.
- { "y" "x" } %untag-fixnums
- "x" operand "y" operand rot execute
- "z" operand "x" operand "y" operand %allot-bignum-signed-1
- "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry T{ template
- { input { { f "x" } { f "y" } } }
- { scratch { { f "z" } } }
- { output { "z" } }
- { clobber { "x" "y" } }
- { gc t }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
-
-: fixnum-value-jump ( op -- pair )
- { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
-
-: fixnum-register-jump ( op -- pair )
- { { f "x" } { f "y" } } fixnum-jump ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< JL }
- { fixnum<= JLE }
- { fixnum> JG }
- { fixnum>= JGE }
- { eq? JE }
-} [
- first2 define-fixnum-jump
-] each
-
-\ fixnum>bignum [
- "x" operand %untag-fixnum
- "x" operand dup "scratch" operand %allot-bignum-signed-1
-] T{ template
- { input { { f "x" } } }
- { scratch { { f "scratch" } } }
- { output { "x" } }
- { gc t }
-} define-intrinsic
-
-\ bignum>fixnum [
- "nonzero" define-label
- "positive" define-label
- "end" define-label
- "x" operand %untag
- "y" operand "x" operand cell [+] MOV
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- "y" operand 1 tag-fixnum CMP
- "nonzero" get JNE
- "y" operand 0 MOV
- "end" get JMP
- "nonzero" resolve-label
- ! load the value
- "y" operand "x" operand 3 cells [+] MOV
- ! load the sign
- "x" operand "x" operand 2 cells [+] MOV
- ! is the sign negative?
- "x" operand 0 CMP
- "positive" get JE
- "y" operand -1 IMUL2
- "positive" resolve-label
- "y" operand 3 SHL
- "end" resolve-label
-] T{ template
- { input { { f "x" } } }
- { scratch { { f "y" } } }
- { clobber { "x" } }
- { output { "y" } }
-} define-intrinsic
-
-! User environment
-: %userenv ( -- )
- "x" operand 0 MOV
- "userenv" f rc-absolute-cell rel-dlsym
- "n" operand fixnum>slot@
- "n" operand "x" operand ADD ;
-
-\ getenv [
- %userenv "n" operand dup [] MOV
-] T{ template
- { input { { f "n" } } }
- { scratch { { f "x" } } }
- { output { "n" } }
-} define-intrinsic
-
-\ setenv [
- %userenv "n" operand [] "val" operand MOV
-] T{ template
- { input { { f "val" } { f "n" } } }
- { scratch { { f "x" } } }
- { clobber { "n" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
- "offset" operand %untag-fixnum
- "offset" operand "alien" operand ADD
- "offset" operand [] swap call ; inline
-
-: %alien-integer-get ( quot reg -- )
- small-reg PUSH
- swap %alien-accessor
- "value" operand small-reg MOV
- "value" operand %tag-fixnum
- small-reg POP ; inline
-
-: alien-integer-get-template
- T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { f "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
- } ;
-
-: define-getter ( word quot reg -- )
- [ %alien-integer-get ] 2curry
- alien-integer-get-template
- define-intrinsic ;
-
-: define-unsigned-getter ( word reg -- )
- [ small-reg dup XOR MOV ] swap define-getter ;
-
-: define-signed-getter ( word reg -- )
- [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
-
-: %alien-integer-set ( quot reg -- )
- small-reg PUSH
- small-reg "value" operand MOV
- small-reg %untag-fixnum
- swap %alien-accessor
- small-reg POP ; inline
-
-: alien-integer-set-template
- T{ template
- { input {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "value" "offset" } }
- } ;
-
-: define-setter ( word reg -- )
- [ swap MOV ] swap
- [ %alien-integer-set ] 2curry
- alien-integer-set-template
- define-intrinsic ;
-
-\ alien-unsigned-1 small-reg-8 define-unsigned-getter
-\ set-alien-unsigned-1 small-reg-8 define-setter
-
-\ alien-signed-1 small-reg-8 define-signed-getter
-\ set-alien-signed-1 small-reg-8 define-setter
-
-\ alien-unsigned-2 small-reg-16 define-unsigned-getter
-\ set-alien-unsigned-2 small-reg-16 define-setter
-
-\ alien-signed-2 small-reg-16 define-signed-getter
-\ set-alien-signed-2 small-reg-16 define-setter
-
-\ alien-cell [
- "value" operand [ MOV ] %alien-accessor
-] T{ template
- { input {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { scratch { { unboxed-alien "value" } } }
- { output { "value" } }
- { clobber { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
- "value" operand [ swap MOV ] %alien-accessor
-] T{ template
- { input {
- { unboxed-c-ptr "value" pinned-c-ptr }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { clobber { "offset" } }
-} define-intrinsic
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
-accessors vectors combinators sets compiler.vops compiler.cfg ;
-IN: compiler.cfg.alias
-
-! Alias analysis -- must be run after compiler.cfg.stack.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
-!
-! All heap-allocated objects which are loaded from the stack, or
-! other object slots are pessimistically assumed to belong to
-! the same alias class.
-!
-! Freshly-allocated objects get their own alias class.
-!
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-!
-! Simple pseudo-C example showing load elimination:
-!
-! int *x, *y, z: inputs
-! int a, b, c, d, e: locals
-!
-! Before alias analysis:
-!
-! a = x[2]
-! b = x[2]
-! c = x[3]
-! y[2] = z
-! d = x[2]
-! e = y[2]
-! f = x[3]
-!
-! After alias analysis:
-!
-! a = x[2]
-! b = a /* ELIMINATED */
-! c = x[3]
-! y[2] = z
-! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
-! e = z /* ELIMINATED */
-! f = c /* ELIMINATED */
-!
-! Simple pseudo-C example showing store elimination:
-!
-! Before alias analysis:
-!
-! x[0] = a
-! b = x[n]
-! x[0] = c
-! x[1] = d
-! e = x[0]
-! x[1] = c
-!
-! After alias analysis:
-!
-! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
-! b = x[n]
-! x[0] = c
-! /* x[1] = d */ /* ELIMINATED */
-! e = c
-! x[1] = c
-
-! Map vregs -> alias classes
-SYMBOL: vregs>acs
-
-: check [ "BUG: static type error detected" throw ] unless* ; inline
-
-: vreg>ac ( vreg -- ac )
- #! Only vregs produced by %%allot, %peek and %%slot can
- #! ever be used as valid inputs to %%slot and %%set-slot,
- #! so we assert this fact by not giving alias classes to
- #! other vregs.
- vregs>acs get at check ;
-
-! Map alias classes -> sequence of vregs
-SYMBOL: acs>vregs
-
-: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-
-: aliases ( vreg -- vregs )
- #! All vregs which may contain the same value as vreg.
- vreg>ac ac>vregs ;
-
-: each-alias ( vreg quot -- )
- [ aliases ] dip each ; inline
-
-! Map vregs -> slot# -> vreg
-SYMBOL: live-slots
-
-! Current instruction number
-SYMBOL: insn#
-
-! Load/store history, for dead store elimination
-TUPLE: load insn# ;
-TUPLE: store insn# ;
-
-: new-action ( class -- action )
- insn# get swap boa ; inline
-
-! Maps vreg -> slot# -> sequence of loads/stores
-SYMBOL: histories
-
-: history ( vreg -- history ) histories get at ;
-
-: set-ac ( vreg ac -- )
- #! Set alias class of newly-seen vreg.
- {
- [ drop H{ } clone swap histories get set-at ]
- [ drop H{ } clone swap live-slots get set-at ]
- [ swap vregs>acs get set-at ]
- [ acs>vregs get push-at ]
- } 2cleave ;
-
-: live-slot ( slot#/f vreg -- vreg' )
- #! If the slot number is unknown, we never reuse a previous
- #! value.
- over [ live-slots get at at ] [ 2drop f ] if ;
-
-: load-constant-slot ( value slot# vreg -- )
- live-slots get at check set-at ;
-
-: load-slot ( value slot#/f vreg -- )
- over [ load-constant-slot ] [ 3drop ] if ;
-
-: record-constant-slot ( slot# vreg -- )
- #! A load can potentially read every store of this slot#
- #! in that alias class.
- [
- history [ load new-action swap ?push ] change-at
- ] with each-alias ;
-
-: record-computed-slot ( vreg -- )
- #! Computed load is like a load of every slot touched so far
- [
- history values [ load new-action swap push ] each
- ] each-alias ;
-
-: remember-slot ( value slot#/f vreg -- )
- over
- [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
- [ 2nip record-computed-slot ] if ;
-
-SYMBOL: ac-counter
-
-: next-ac ( -- n )
- ac-counter [ dup 1+ ] change ;
-
-! Alias class for objects which are loaded from the data stack
-! or other object slots. We pessimistically assume that they
-! can all alias each other.
-SYMBOL: heap-ac
-
-: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
-
-: set-new-ac ( vreg -- ) next-ac set-ac ;
-
-: kill-constant-set-slot ( slot# vreg -- )
- [ live-slots get at delete-at ] with each-alias ;
-
-: record-constant-set-slot ( slot# vreg -- )
- history [
- dup empty? [ dup peek store? [ dup pop* ] when ] unless
- store new-action swap ?push
- ] change-at ;
-
-: kill-computed-set-slot ( ac -- )
- [ live-slots get at clear-assoc ] each-alias ;
-
-: remember-set-slot ( slot#/f vreg -- )
- over [
- [ record-constant-set-slot ]
- [ kill-constant-set-slot ] 2bi
- ] [ nip kill-computed-set-slot ] if ;
-
-SYMBOL: copies
-
-: resolve ( vreg -- vreg )
- dup copies get at swap or ;
-
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
- #! Return an %iconst value, or f if the vreg was not
- #! assigned by an %iconst.
- resolve constants get at ;
-
-! We treat slot accessors and stack traffic alike
-GENERIC: insn-slot# ( insn -- slot#/f )
-GENERIC: insn-object ( insn -- vreg )
-
-M: %peek insn-slot# n>> ;
-M: %replace insn-slot# n>> ;
-M: %%slot insn-slot# slot>> constant ;
-M: %%set-slot insn-slot# slot>> constant ;
-
-M: %peek insn-object stack>> ;
-M: %replace insn-object stack>> ;
-M: %%slot insn-object obj>> resolve ;
-M: %%set-slot insn-object obj>> resolve ;
-
-: init-alias-analysis ( -- )
- H{ } clone histories set
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone constants set
- H{ } clone copies set
-
- 0 ac-counter set
- next-ac heap-ac set
-
- %data next-ac set-ac
- %retain next-ac set-ac ;
-
-GENERIC: analyze-aliases ( insn -- insn' )
-
-M: %iconst analyze-aliases
- dup [ value>> ] [ out>> ] bi constants get set-at ;
-
-M: %%allot analyze-aliases
- #! A freshly allocated object is distinct from any other
- #! object.
- dup out>> set-new-ac ;
-
-M: read-op analyze-aliases
- dup out>> set-heap-ac
- dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
- 2dup live-slot dup [
- 2nip %copy boa analyze-aliases nip
- ] [
- drop remember-slot
- ] if ;
-
-: idempotent? ( value slot#/f vreg -- ? )
- #! Are we storing a value back to the same slot it was read
- #! from?
- live-slot = ;
-
-M: write-op analyze-aliases
- dup
- [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
- 3dup idempotent? [
- 2drop 2drop nop
- ] [
- [ remember-set-slot drop ] [ load-slot ] 3bi
- ] if ;
-
-M: %copy analyze-aliases
- #! The output vreg gets the same alias class as the input
- #! vreg, since they both contain the same value.
- dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
-
-M: vop analyze-aliases ;
-
-SYMBOL: live-stores
-
-: compute-live-stores ( -- )
- histories get
- values [
- values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat unique
- live-stores set ;
-
-GENERIC: eliminate-dead-store ( insn -- insn' )
-
-: (eliminate-dead-store) ( insn -- insn' )
- dup insn-slot# [
- insn# get live-stores get key? [
- drop nop
- ] unless
- ] when ;
-
-M: %replace eliminate-dead-store
- #! Writes to above the top of the stack can be pruned also.
- #! This is sound since any such writes are not observable
- #! after the basic block, and any reads of those locations
- #! will have been converted to copies by analyze-slot,
- #! and the final stack height of the basic block is set at
- #! the beginning by compiler.cfg.stack.
- dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
-
-M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
-
-M: vop eliminate-dead-store ;
-
-: alias-analysis ( insns -- insns' )
- init-alias-analysis
- [ insn# set analyze-aliases ] map-index
- compute-live-stores
- [ insn# set eliminate-dead-store ] map-index ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: compiler.cfg.builder.tests
-USING: compiler.cfg.builder tools.test ;
-
-\ build-cfg must-infer
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel assocs sequences sequences.lib fry accessors
-namespaces math combinators math.order
-compiler.tree
-compiler.tree.combinators
-compiler.tree.propagation.info
-compiler.cfg
-compiler.vops
-compiler.vops.builder ;
-IN: compiler.cfg.builder
-
-! Convert tree SSA IR to CFG SSA IR.
-
-! We construct the graph and set successors first, then we
-! set predecessors in a separate pass. This simplifies the
-! logic.
-
-SYMBOL: procedures
-
-SYMBOL: loop-nesting
-
-SYMBOL: values>vregs
-
-GENERIC: convert ( node -- )
-
-M: #introduce convert drop ;
-
-: init-builder ( -- )
- H{ } clone values>vregs set ;
-
-: end-basic-block ( -- )
- basic-block get [ %b emit ] when ;
-
-: set-basic-block ( basic-block -- )
- [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
- <basic-block> basic-block get
- [
- end-basic-block
- dupd successors>> push
- ] when*
- set-basic-block ;
-
-: convert-nodes ( node -- )
- [ convert ] each ;
-
-: (build-cfg) ( node word -- )
- init-builder
- begin-basic-block
- basic-block get swap procedures get set-at
- convert-nodes ;
-
-: build-cfg ( node word -- procedures )
- H{ } clone [
- procedures [ (build-cfg) ] with-variable
- ] keep ;
-
-: value>vreg ( value -- vreg )
- values>vregs get at ;
-
-: output-vreg ( value vreg -- )
- swap values>vregs get set-at ;
-
-: produce-vreg ( value -- vreg )
- next-vreg [ output-vreg ] keep ;
-
-: (load-inputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ '[ produce-vreg _ , %peek emit ] each-index ]
- [ [ length neg ] dip %height emit ]
- 2bi
- ] if ;
-
-: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
-
-: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
-
-: (store-outputs) ( seq stack -- )
- over empty? [ 2drop ] [
- [ <reversed> ] dip
- [ [ length ] dip %height emit ]
- [ '[ value>vreg _ , %replace emit ] each-index ]
- 2bi
- ] if ;
-
-: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
-
-: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
-
-: (emit-call) ( word -- )
- begin-basic-block %call emit begin-basic-block ;
-
-: intrinsic-inputs ( node -- )
- [ load-in-d ]
- [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
- bi ;
-
-: intrinsic-outputs ( node -- )
- [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
- [ store-out-d ]
- bi ;
-
-: intrinsic ( node quot -- )
- [
- init-intrinsic
-
- [ intrinsic-inputs ]
- swap
- [ intrinsic-outputs ]
- tri
- ] with-scope ; inline
-
-USING: kernel.private math.private slots.private ;
-
-: maybe-emit-fixnum-shift-fast ( node -- node )
- dup dup in-d>> second node-value-info literal>> dup fixnum? [
- '[ , emit-fixnum-shift-fast ] intrinsic
- ] [
- drop dup word>> (emit-call)
- ] if ;
-
-: emit-call ( node -- )
- dup word>> {
- { \ tag [ [ emit-tag ] intrinsic ] }
-
- { \ slot [ [ dup emit-slot ] intrinsic ] }
- { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
-
- { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
- { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
- { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
- { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
- { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
- { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
- { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
- { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
- { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
- { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
- { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
- { \ eq? [ [ emit-eq? ] intrinsic ] }
-
- { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
-
- { \ float+ [ [ emit-float+ ] intrinsic ] }
- { \ float- [ [ emit-float- ] intrinsic ] }
- { \ float* [ [ emit-float* ] intrinsic ] }
- { \ float/f [ [ emit-float/f ] intrinsic ] }
- { \ float<= [ [ emit-float<= ] intrinsic ] }
- { \ float>= [ [ emit-float>= ] intrinsic ] }
- { \ float< [ [ emit-float< ] intrinsic ] }
- { \ float> [ [ emit-float> ] intrinsic ] }
- { \ float? [ [ emit-float= ] intrinsic ] }
-
- ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
- ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
- ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
-
- [ (emit-call) ]
- } case drop ;
-
-M: #call convert emit-call ;
-
-: emit-call-loop ( #recursive -- )
- dup label>> loop-nesting get at basic-block get successors>> push
- end-basic-block
- basic-block off
- drop ;
-
-: emit-call-recursive ( #recursive -- )
- label>> id>> (emit-call) ;
-
-M: #call-recursive convert
- dup label>> loop?>>
- [ emit-call-loop ] [ emit-call-recursive ] if ;
-
-M: #push convert
- [
- [ out-d>> first produce-vreg ]
- [ node-output-infos first literal>> ]
- bi emit-literal
- ]
- [ store-out-d ] bi ;
-
-M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
-
-M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
-
-M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
-
-M: #terminate convert drop ;
-
-: integer-conditional ( in1 in2 cc -- )
- [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
-
-: float-conditional ( in1 in2 branch -- )
- [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
-
-: emit-if ( #if -- )
- in-d>> first value>vreg
- next-vreg dup f emit-literal
- cc/= integer-conditional ;
-
-: convert-nested ( node -- last-bb )
- [
- <basic-block>
- [ set-basic-block ] keep
- [ convert-nodes end-basic-block ] dip
- basic-block get
- ] with-scope
- [ basic-block get successors>> push ] dip ;
-
-: convert-if-children ( #if -- )
- children>> [ convert-nested ] map sift
- <basic-block>
- [ '[ , _ successors>> push ] each ]
- [ set-basic-block ]
- bi ;
-
-M: #if convert
- [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
-
-M: #dispatch convert
- "Unimplemented" throw ;
-
-M: #phi convert drop ;
-
-M: #declare convert drop ;
-
-M: #return convert drop %return emit ;
-
-: convert-recursive ( #recursive -- )
- [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
- [ (emit-call) ]
- bi ;
-
-: begin-loop ( #recursive -- )
- label>> basic-block get 2array loop-nesting get push ;
-
-: end-loop ( -- )
- loop-nesting get pop* ;
-
-: convert-loop ( #recursive -- )
- begin-basic-block
- [ begin-loop ]
- [ child>> convert-nodes ]
- [ drop end-loop ]
- tri ;
-
-M: #recursive convert
- dup label>> loop?>>
- [ convert-loop ] [ convert-recursive ] if ;
-
-M: #copy convert drop ;
+++ /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
-
-! The id is a globally unique id used for fast hashcode* and
-! equal? on basic blocks. The number is assigned by
-! linearization.
-TUPLE: basic-block < identity-tuple
-id
-number
-instructions
-successors
-predecessors
-stack-frame ;
-
-SYMBOL: next-block-id
-
-: <basic-block> ( -- basic-block )
- basic-block new
- next-block-id counter >>id
- V{ } clone >>instructions
- V{ } clone >>successors
- V{ } clone >>predecessors ;
-
-M: basic-block hashcode* id>> nip ;
-
-! Utilities
-SYMBOL: visited-blocks
-
-: visit-block ( basic-block quot -- )
- over visited-blocks get 2dup key?
- [ 2drop 2drop ] [ conjoin call ] if ; inline
-
-: (each-block) ( basic-block quot -- )
- '[
- ,
- [ call ]
- [ [ successors>> ] dip '[ , (each-block) ] each ]
- 2bi
- ] visit-block ; inline
-
-: each-block ( basic-block quot -- )
- H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
-
-: copy-at ( from to assoc -- )
- 3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces math layouts sequences locals
-combinators compiler.vops compiler.vops.builder
-compiler.cfg.builder ;
-IN: compiler.cfg.elaboration
-
-! This pass must run before conversion to machine IR to ensure
-! correctness.
-
-GENERIC: elaborate* ( insn -- )
-
-: slot-shift ( -- n )
- tag-bits get cell log2 - ;
-
-:: compute-slot-known-tag ( insn -- addr )
- { $1 $2 $3 $4 $5 } temps
- init-intrinsic
- $1 slot-shift %iconst emit ! load shift offset
- $2 insn slot>> $1 %shr emit ! shift slot by shift offset
- $3 insn tag>> %iconst emit ! load tag number
- $4 $2 $3 %isub emit
- $5 insn obj>> $4 %iadd emit ! compute slot offset
- $5
- ;
-
-:: compute-slot-any-tag ( insn -- addr )
- { $1 $2 $3 $4 } temps
- init-intrinsic
- $1 insn obj>> emit-untag ! untag object
- $2 slot-shift %iconst emit ! load shift offset
- $3 insn slot>> $2 %shr emit ! shift slot by shift offset
- $4 $1 $3 %iadd emit ! compute slot offset
- $4
- ;
-
-: compute-slot ( insn -- addr )
- dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
-
-M: %%slot elaborate*
- [ out>> ] [ compute-slot ] bi %load emit ;
-
-M: %%set-slot elaborate*
- [ in>> ] [ compute-slot ] bi %store emit ;
-
-M: object elaborate* , ;
-
-: elaboration ( insns -- insns )
- [ [ elaborate* ] each ] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel compiler.vops ;
-IN: compiler.cfg.kill-nops
-
-! Smallest compiler pass ever.
-
-: kill-nops ( instructions -- instructions' )
- [ nop? not ] filter ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors math.order sequences
-compiler.vops ;
-IN: compiler.cfg.live-ranges
-
-TUPLE: live-range from to ;
-
-! Maps vregs to live ranges
-SYMBOL: live-ranges
-
-: def ( n vreg -- )
- [ dup live-range boa ] dip live-ranges get set-at ;
-
-: use ( n vreg -- )
- live-ranges get at [ max ] change-to drop ;
-
-GENERIC: compute-live-ranges* ( n insn -- )
-
-M: nullary-op compute-live-ranges*
- 2drop ;
-
-M: flushable-op compute-live-ranges*
- out>> def ;
-
-M: effect-op compute-live-ranges*
- in>> use ;
-
-M: unary-op compute-live-ranges*
- [ out>> def ] [ in>> use ] 2bi ;
-
-M: binary-op compute-live-ranges*
- [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
-
-M: %store compute-live-ranges*
- [ call-next-method ] [ addr>> use ] 2bi ;
-
-: compute-live-ranges ( insns -- )
- H{ } clone live-ranges set
- [ swap compute-live-ranges* ] each-index ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg kernel accessors sequences ;
-IN: compiler.cfg.predecessors
-
-! Pass to compute precedecessors.
-
-: compute-predecessors ( procedure -- )
- [
- dup successors>>
- [ predecessors>> push ] with each
- ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.cfg
-compiler.cfg.predecessors
-compiler.cfg.stack
-compiler.cfg.alias
-compiler.cfg.write-barrier
-compiler.cfg.elaboration
-compiler.cfg.vn
-compiler.cfg.vn.conditions
-compiler.cfg.kill-nops ;
-IN: compiler.cfg.simplifier
-
-: simplify ( insns -- insns' )
- normalize-height
- alias-analysis
- elaboration
- value-numbering
- eliminate-write-barrier
- kill-nops ;
-
-: simplify-cfg ( procedure -- procedure )
- dup compute-predecessors
- dup [ [ simplify ] change-instructions drop ] each-block ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.vops ;
-IN: compiler.cfg.stack
-
-! Combine multiple stack height changes into one, done at the
-! start of the basic block.
-!
-! Alias analysis and value numbering assume this optimization
-! has been performed.
-
-! Current data and retain stack height is stored in
-! %data, %retain variables.
-GENERIC: compute-heights ( insn -- )
-
-M: %height compute-heights
- [ n>> ] [ stack>> ] bi [ + ] change ;
-
-M: object compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn )
-
-M: %height normalize-height*
- [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
-
-: (normalize-height) ( insn -- insn )
- dup stack>> get '[ , + ] change-n ; inline
-
-M: %peek normalize-height* (normalize-height) ;
-
-M: %replace normalize-height* (normalize-height) ;
-
-M: object normalize-height* ;
-
-: normalize-height ( insns -- insns' )
- 0 %data set
- 0 %retain set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map ] with-scope ] bi
- %data get dup zero? [ drop ] [ %data %height boa prefix ] if
- %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
+++ /dev/null
-Low-level optimizer operating on control flow graph SSA IR
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.liveness
-compiler.cfg.vn ;
-IN: compiler.cfg.vn.conditions
-
-! The CFG generator produces naive code for the following code
-! sequence:
-!
-! fixnum< [ ... ] [ ... ] if
-!
-! The fixnum< comparison generates a boolean, which is then
-! tested against f.
-!
-! Using value numbering, we optimize the comparison of a boolean
-! against f where the boolean is the result of comparison.
-
-: expr-f? ( expr -- ? )
- dup op>> %iconst eq?
- [ value>> \ f tag-number = ] [ drop f ] if ;
-
-: comparison-with-f? ( insn -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- dup code>> cc/= eq? [
- in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
- ] [ drop f f ] if ;
-
-: of-boolean? ( expr -- expr/f ? )
- #! The expr is a binary-op %icmp or %fcmp.
- in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
-
-: original-comparison ( expr -- in/f code/f )
- [ in>> vn>vreg ] [ code>> ] bi ;
-
-: eliminate-boolean ( insn -- in/f code/f )
- comparison-with-f? [
- of-boolean? [
- original-comparison
- ] [ drop f f ] if
- ] [ drop f f ] if ;
-
-M: cond-branch make-value-node
- #! If the conditional branch is testing the result of an
- #! earlier comparison against f, we only mark as live the
- #! earlier comparison, so DCE will eliminate the boolean.
- dup eliminate-boolean drop swap in>> or live-vreg ;
-
-M: cond-branch eliminate
- dup eliminate-boolean dup
- [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel compiler.vops compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.constant-fold
-
-GENERIC: constant-fold ( insn -- insn' )
-
-M: vop constant-fold ;
-
-: expr>insn ( out constant-expr -- constant-op )
- [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
-
-M: pure-op constant-fold
- dup out>>
- dup vreg>vn vn>expr
- dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces sorting
-compiler.vops compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.expressions
-
-! Referentially-transparent expressions
-TUPLE: expr op ;
-TUPLE: nullary-expr < expr ;
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: boolean-expr < unary-expr code ;
-TUPLE: constant-expr < expr value ;
-TUPLE: literal-expr < unary-expr object ;
-
-! op is always %peek
-TUPLE: peek-expr < expr loc ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
- input-expr-counter [ dup 1 + ] change ;
-
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-GENERIC: >expr ( insn -- expr )
-
-M: %literal-table >expr
- class nullary-expr boa ;
-
-M: constant-op >expr
- [ class ] [ value>> ] bi constant-expr boa ;
-
-M: %literal >expr
- [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
-
-M: unary-op >expr
- [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
-
-M: binary-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: commutative-op >expr
- [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
- sort-pair commutative-expr boa ;
-
-M: boolean-op >expr
- [ class ] [ in>> vreg>vn ] [ code>> ] tri
- boolean-expr boa ;
-
-M: %peek >expr
- [ class ] [ stack-loc ] bi peek-expr boa ;
-
-M: flushable-op >expr
- class next-input-expr input-expr boa ;
-
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs biassocs accessors
-math.order prettyprint.backend parser ;
-IN: compiler.cfg.vn.graph
-
-TUPLE: vn n ;
-
-SYMBOL: vn-counter
-
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
-
-: VN: scan-word vn boa parsed ; parsing
-
-M: vn <=> [ n>> ] compare ;
-
-M: vn pprint* \ VN: pprint-word n>> pprint* ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-SYMBOL: vregs>vns
-
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
-
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
-
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-
-: init-value-graph ( -- )
- 0 vn-counter set
- <bihash> exprs>vns set
- <bihash> vregs>vns set ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sets accessors compiler.vops
-compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.liveness
-
-! A set of VNs which are (transitively) used by effect-ops. This
-! is precisely the set of VNs whose value is needed outside of
-! the basic block.
-SYMBOL: live-vns
-
-GENERIC: live-expr ( expr -- )
-
-: live-vn ( vn -- )
- #! Mark a VN and all VNs used in its computation as live.
- dup live-vns get key? [ drop ] [
- [ live-vns get conjoin ] [ vn>expr live-expr ] bi
- ] if ;
-
-: live-vreg ( vreg -- ) vreg>vn live-vn ;
-
-M: expr live-expr drop ;
-M: literal-expr live-expr in>> live-vn ;
-M: unary-expr live-expr in>> live-vn ;
-M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
-
-: live? ( vreg -- ? )
- dup vreg>vn tuck vn>vreg =
- [ live-vns get key? ] [ drop f ] if ;
-
-: init-liveness ( -- )
- H{ } clone live-vns set ;
-
-GENERIC: eliminate ( insn -- insn' )
-
-M: flushable-op eliminate dup out>> live? ?nop ;
-M: vop eliminate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.vops
-compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
-
-GENERIC: propogate ( insn -- insn )
-
-M: effect-op propogate
- [ resolve ] change-in ;
-
-M: unary-op propogate
- [ resolve ] change-in ;
-
-M: binary-op propogate
- [ resolve ] change-in1
- [ resolve ] change-in2 ;
-
-M: %phi propogate
- [ [ resolve ] map ] change-in ;
-
-M: %%slot propogate
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %%set-slot propogate
- call-next-method
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: %store propogate
- call-next-method
- [ resolve ] change-addr ;
-
-M: nullary-op propogate ;
-
-M: flushable-op propogate ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math math.order
-layouts locals
-compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-: constant ( val type -- expr ) swap constant-expr boa ;
-
-: simplify-not ( in -- vn/expr/f )
- {
- { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
- { [ dup op>> %not = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-box-float ( in -- vn/expr/f )
- {
- { [ dup op>> %%unbox-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-: simplify-unbox-float ( in -- vn/expr/f )
- {
- { [ dup literal-expr? ] [ object>> %fconst constant ] }
- { [ dup op>> %%box-float = ] [ in>> ] }
- [ drop f ]
- } cond ;
-
-M: unary-expr simplify*
- #! Note the copy propagation: a %copy always simplifies to
- #! its source vn.
- [ in>> vn>expr ] [ op>> ] bi {
- { %copy [ ] }
- { %not [ simplify-not ] }
- { %%box-float [ simplify-box-float ] }
- { %%unbox-float [ simplify-unbox-float ] }
- [ 2drop f ]
- } case ;
-
-: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
-
-: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
-
-: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
-
-: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
-
-: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
-
-: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
-
-: identity ( in1 in2 val type -- expr ) constant 2nip ;
-
-: constant-fold? ( in1 in2 -- ? )
- [ constant-expr? ] both? ;
-
-:: constant-fold ( in1 in2 quot type -- expr )
- in1 in2 constant-fold?
- [ in1 value>> in2 value>> quot call type constant ]
- [ f ]
- if ; inline
-
-: simplify-iadd ( in1 in2 -- vn/expr/f )
- {
- { [ over izero? ] [ nip ] }
- { [ dup izero? ] [ drop ] }
- [ [ + ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imul ( in1 in2 -- vn/expr/f )
- {
- { [ over ione? ] [ nip ] }
- { [ dup ione? ] [ drop ] }
- [ [ * ] %iconst constant-fold ]
- } cond ;
-
-: simplify-and ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ 0 %iconst identity ] }
- { [ dup ineg-one? ] [ drop ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitand ] %iconst constant-fold ]
- } cond ;
-
-: simplify-or ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ dup ineg-one? ] [ -1 %iconst identity ] }
- { [ 2dup = ] [ drop ] }
- [ [ bitor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-xor ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ bitxor ] %iconst constant-fold ]
- } cond ;
-
-: simplify-fadd ( in1 in2 -- vn/expr/f )
- {
- { [ over fzero? ] [ nip ] }
- { [ dup fzero? ] [ drop ] }
- [ [ + ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fmul ( in1 in2 -- vn/expr/f )
- {
- { [ over fone? ] [ nip ] }
- { [ dup fone? ] [ drop ] }
- [ [ * ] %fconst constant-fold ]
- } cond ;
-
-: commutative-operands ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi
- over constant-expr? [ swap ] when ;
-
-M: commutative-expr simplify*
- [ commutative-operands ] [ op>> ] bi {
- { %iadd [ simplify-iadd ] }
- { %imul [ simplify-imul ] }
- { %and [ simplify-and ] }
- { %or [ simplify-or ] }
- { %xor [ simplify-xor ] }
- { %fadd [ simplify-fadd ] }
- { %fmul [ simplify-fmul ] }
- [ 3drop f ]
- } case ;
-
-: simplify-isub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ - ] %iconst constant-fold ]
- } cond ;
-
-: simplify-idiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ drop ] }
- [ [ /i ] %iconst constant-fold ]
- } cond ;
-
-: simplify-imod ( in1 in2 -- vn/expr/f )
- {
- { [ dup ione? ] [ 0 %iconst identity ] }
- { [ 2dup = ] [ 0 %iconst identity ] }
- [ [ mod ] %iconst constant-fold ]
- } cond ;
-
-: simplify-shl ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- [ [ shift ] %iconst constant-fold ]
- } cond ;
-
-: unsigned ( n -- n' )
- cell-bits 2^ 1- bitand ;
-
-: useless-shift? ( in1 in2 -- ? )
- over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
-
-: simplify-shr ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift unsigned ] %iconst constant-fold ]
- } cond ;
-
-: simplify-sar ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- { [ over izero? ] [ drop ] }
- { [ 2dup useless-shift? ] [ drop in1>> ] }
- [ [ neg shift ] %iconst constant-fold ]
- } cond ;
-
-: simplify-icmp ( in1 in2 -- vn/expr/f )
- = [ +eq+ %cconst constant ] [ f ] if ;
-
-: simplify-fsub ( in1 in2 -- vn/expr/f )
- {
- { [ dup izero? ] [ drop ] }
- [ [ - ] %fconst constant-fold ]
- } cond ;
-
-: simplify-fdiv ( in1 in2 -- vn/expr/f )
- {
- { [ dup fone? ] [ drop ] }
- [ [ /i ] %fconst constant-fold ]
- } cond ;
-
-M: binary-expr simplify*
- [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
- { %isub [ simplify-isub ] }
- { %idiv [ simplify-idiv ] }
- { %imod [ simplify-imod ] }
- { %shl [ simplify-shl ] }
- { %shr [ simplify-shr ] }
- { %sar [ simplify-sar ] }
- { %icmp [ simplify-icmp ] }
- { %fsub [ simplify-fsub ] }
- { %fdiv [ simplify-fdiv ] }
- [ 3drop f ]
- } case ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
- dup simplify* {
- { [ dup not ] [ drop expr>vn ] }
- { [ dup expr? ] [ expr>vn nip ] }
- { [ dup vn? ] [ nip ] }
- } cond ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.simplify
-compiler.cfg.vn.liveness
-compiler.cfg.vn.constant-fold
-compiler.cfg.vn.propagate ;
-IN: compiler.cfg.vn
-
-: insn>vn ( insn -- vn ) >expr simplify ; inline
-
-GENERIC: make-value-node ( insn -- )
-M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
-M: effect-op make-value-node in>> live-vreg ;
-M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
-M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
-M: nullary-op make-value-node drop ;
-
-: init-value-numbering ( -- )
- init-value-graph
- init-expressions
- init-liveness ;
-
-: value-numbering ( instructions -- instructions )
- init-value-numbering
- [ [ make-value-node ] each ]
- [ [ eliminate constant-fold propogate ] map ]
- bi ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences
-compiler.vops compiler.cfg ;
-IN: compiler.cfg.write-barrier
-
-! Eliminate redundant write barrier hits.
-SYMBOL: hits
-
-GENERIC: eliminate-write-barrier* ( insn -- insn' )
-
-M: %%allot eliminate-write-barrier*
- dup out>> hits get conjoin ;
-
-M: %write-barrier eliminate-write-barrier*
- dup in>> hits get key?
- [ drop nop ] [ dup in>> hits get conjoin ] if ;
-
-M: %copy eliminate-write-barrier*
- dup in/out hits get copy-at ;
-
-M: vop eliminate-write-barrier* ;
-
-: eliminate-write-barrier ( insns -- insns )
- H{ } clone hits set
- [ eliminate-write-barrier* ] map ;
+++ /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.
-IN: compiler.lvops
-
-! Machine representation ("linear virtual operations"). Uses
-! same operations as CFG basic blocks, except edges and branches
-! are replaced by linear jumps (_b* instances).
-
-TUPLE: _label label ;
-
-! Unconditional jump to label
-TUPLE: _b label ;
-
-! Integer
-TUPLE: _bi label in code ;
-TUPLE: _bf label in code ;
-
-! Dispatch table, jumps to one of following _address
-! depending value of 'in'
-TUPLE: _dispatch in ;
-TUPLE: _address word ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces
-compiler.cfg compiler.vops compiler.lvops ;
-IN: compiler.machine.builder
-
-SYMBOL: block-counter
-
-: number-basic-block ( basic-block -- )
- #! Make this fancy later.
- dup number>> [ drop ] [
- block-counter [ dup 1+ ] change >>number
- [ , ] [
- successors>> <reversed>
- [ number-basic-block ] each
- ] bi
- ] if ;
-
-: flatten-basic-blocks ( procedure -- blocks )
- [
- 0 block-counter
- [ number-basic-block ]
- with-variable
- ] { } make ;
-
-GENERIC: linearize-instruction ( basic-block insn -- )
-
-M: object linearize-instruction
- , drop ;
-
-M: %b linearize-instruction
- drop successors>> first number>> _b emit ;
-
-: conditional-branch ( basic-block insn class -- )
- [ successors>> ] 2dip
- [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
- [ 2drop second number>> _b emit ]
- 3bi ; inline
-
-M: %bi linearize-instruction _bi conditional-branch ;
-M: %bf linearize-instruction _bf conditional-branch ;
-
-: build-mr ( procedure -- insns )
- [
- flatten-basic-blocks [
- [ number>> _label emit ]
- [ dup instructions>> [ linearize-instruction ] with each ]
- bi
- ] each
- ] { } make ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer
-compiler.vops
-compiler.tree.builder
-compiler.tree.optimizer
-compiler.cfg.builder
-compiler.cfg.simplifier
-compiler.machine.builder
-compiler.machine.simplifier ;
-IN: compiler.machine.debugger
-
-: tree>linear ( tree word -- linear )
- [
- init-counter
- build-cfg
- [ simplify-cfg build-mr simplify-mr ] assoc-map
- ] with-scope ;
-
-: linear. ( linear -- )
- [
- "==== " write swap .
- [ . ] each
- ] assoc-each ;
-
-: linearized-quot. ( quot -- )
- build-tree optimize-tree
- "Anonymous quotation" tree>linear
- linear. ;
-
-: linearized-word. ( word -- )
- dup build-tree-from-word nip optimize-tree
- dup word-dataflow nip optimize swap tree>linear linear. ;
-
-: >basic-block ( quot -- basic-block )
- build-tree optimize-tree
- [
- init-counter
- "Anonymous quotation" build-cfg
- >alist first second simplify-cfg
- ] with-scope ;
-
-: basic-block. ( basic-block -- )
- instructions>> [ . ] each ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces sequences.next compiler.lvops ;
-IN: compiler.machine.simplifier
-
-: useless-branch? ( next insn -- ? )
- 2dup [ _label? ] [ _b? ] bi* and
- [ [ label>> ] bi@ = ] [ 2drop f ] if ;
-
-: simplify-mr ( insns -- insns )
- #! Remove unconditional branches to labels immediately
- #! following.
- [
- [
- tuck useless-branch?
- [ drop ] [ , ] if
- ] each-next
- ] { } make ;
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state stack-checker.inlining
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
-IN: compiler.new
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
- {
- { [ dup "forgotten" word-prop ] [ ] }
- { [ dup compiled get key? ] [ ] }
- { [ dup inlined-block? ] [ ] }
- { [ dup primitive? ] [ ] }
- [ dup compile-queue get push-front ]
- } cond drop ;
-
-: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: +failed+
-
-: ripple-up ( words -- )
- dup "compiled-effect" word-prop +failed+ eq?
- [ usage [ word? ] filter ] [ compiled-usage keys ] if
- [ queue-compile ] each ;
-
-: ripple-up? ( word effect -- ? )
- #! If the word has previously been compiled and had a
- #! different stack effect, we have to recompile any callers.
- swap "compiled-effect" word-prop [ = not ] keep and ;
-
-: save-effect ( word effect -- )
- [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
- [ "compiled-effect" set-word-prop ]
- 2bi ;
-
-: start ( word -- )
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
- f swap compiler-error ;
-
-: fail ( word error -- )
- [ swap compiler-error ]
- [
- drop
- [ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +failed+ save-effect ]
- tri
- ] 2bi
- return ;
-
-: frontend ( word -- effect nodes )
- [ build-tree-from-word ] [ fail ] recover optimize-tree ;
-
-: finish ( effect word -- )
- [ swap save-effect ]
- [ compiled-unxref ]
- [
- dup crossref?
- [
- dependencies get >alist
- generic-dependencies get >alist
- compiled-xref
- ] [ drop ] if
- ] tri ;
-
-: save-asm ( asm -- )
- [ [ code>> ] [ label>> ] bi compiled get set-at ]
- [ calls>> [ queue-compile ] each ]
- bi ;
-
-: backend ( nodes word -- )
- build-cfg [
- build-mr
- linear-scan
- build-stack-frame
- generate
- save-asm
- ] each ;
-
-: (compile) ( word -- )
- '[
- _ {
- [ start ]
- [ frontend ]
- [ backend ]
- [ finish ]
- } cleave
- ] with-return ;
-
-: compile-loop ( deque -- )
- [ (compile) yield ] slurp-deque ;
-
-: decompile ( word -- )
- f 2array 1array t modify-code-heap ;
-
-: optimized-recompile-hook ( words -- alist )
- [
- <hashed-dlist> compile-queue set
- H{ } clone compiled set
- [ queue-compile ] each
- compile-queue get compile-loop
- compiled get >alist
- ] with-scope ;
-
-: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
-
-: recompile-all ( -- )
- forget-errors all-words compile ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces words layouts sequences classes
-classes.algebra accessors math arrays byte-arrays
-inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
-IN: compiler.vops.builder
-
-<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
-
-! Temps Inputs Outputs
-TEMP: $1 TEMP: #1 TEMP: ^1
-TEMP: $2 TEMP: #2 TEMP: ^2
-TEMP: $3 TEMP: #3 TEMP: ^3
-TEMP: $4 TEMP: #4 TEMP: ^4
-TEMP: $5 TEMP: #5 TEMP: ^5
-
-GENERIC: emit-literal ( vreg object -- )
-
-M: fixnum emit-literal ( vreg object -- )
- tag-bits get shift %iconst emit ;
-
-M: f emit-literal
- class tag-number %iconst emit ;
-
-M: object emit-literal ( vreg object -- )
- next-vreg [ %literal-table emit ] keep
- swap %literal emit ;
-
-: temps ( seq -- ) [ next-vreg swap set ] each ;
-
-: init-intrinsic ( -- )
- { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
-
-: load-iconst ( value -- vreg )
- [ next-vreg dup ] dip %iconst emit ;
-
-: load-tag-mask ( -- vreg )
- tag-mask get load-iconst ;
-
-: load-tag-bits ( -- vreg )
- tag-bits get load-iconst ;
-
-: emit-tag-fixnum ( out in -- )
- load-tag-bits %shl emit ;
-
-: emit-untag-fixnum ( out in -- )
- load-tag-bits %sar emit ;
-
-: emit-untag ( out in -- )
- next-vreg dup tag-mask get bitnot %iconst emit
- %and emit ;
-
-: emit-tag ( -- )
- $1 #1 load-tag-mask %and emit
- ^1 $1 emit-tag-fixnum ;
-
-: emit-slot ( node -- )
- [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: emit-write-barrier ( node -- )
- dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
-
-: emit-set-slot ( node -- )
- [ emit-write-barrier ]
- [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
- bi ;
-
-: emit-fixnum-bitnot ( -- )
- $1 #1 %not emit
- ^1 $1 load-tag-mask %xor emit ;
-
-: emit-fixnum+fast ( -- )
- ^1 #1 #2 %iadd emit ;
-
-: emit-fixnum-fast ( -- )
- ^1 #1 #2 %isub emit ;
-
-: emit-fixnum-bitand ( -- )
- ^1 #1 #2 %and emit ;
-
-: emit-fixnum-bitor ( -- )
- ^1 #1 #2 %or emit ;
-
-: emit-fixnum-bitxor ( -- )
- ^1 #1 #2 %xor emit ;
-
-: emit-fixnum*fast ( -- )
- $1 #1 emit-untag-fixnum
- ^1 $1 #2 %imul emit ;
-
-: emit-fixnum-shift-left-fast ( n -- )
- [ $1 ] dip %iconst emit
- ^1 #1 $1 %shl emit ;
-
-: emit-fixnum-shift-right-fast ( n -- )
- [ $1 ] dip %iconst emit
- $2 #1 $1 %sar emit
- ^1 $2 emit-untag ;
-
-: emit-fixnum-shift-fast ( n -- )
- dup 0 >=
- [ emit-fixnum-shift-left-fast ]
- [ neg emit-fixnum-shift-right-fast ] if ;
-
-: emit-fixnum-compare ( cc -- )
- $1 #1 #2 %icmp emit
- [ ^1 $1 ] dip %%iboolean emit ;
-
-: emit-fixnum<= ( -- )
- cc<= emit-fixnum-compare ;
-
-: emit-fixnum>= ( -- )
- cc>= emit-fixnum-compare ;
-
-: emit-fixnum< ( -- )
- cc< emit-fixnum-compare ;
-
-: emit-fixnum> ( -- )
- cc> emit-fixnum-compare ;
-
-: emit-eq? ( -- )
- cc= emit-fixnum-compare ;
-
-: emit-unbox-float ( out in -- )
- %%unbox-float emit ;
-
-: emit-box-float ( out in -- )
- %%box-float emit ;
-
-: emit-unbox-floats ( -- )
- $1 #1 emit-unbox-float
- $2 #2 emit-unbox-float ;
-
-: emit-float+ ( -- )
- emit-unbox-floats
- $3 $1 $2 %fadd emit
- ^1 $3 emit-box-float ;
-
-: emit-float- ( -- )
- emit-unbox-floats
- $3 $1 $2 %fsub emit
- ^1 $3 emit-box-float ;
-
-: emit-float* ( -- )
- emit-unbox-floats
- $3 $1 $2 %fmul emit
- ^1 $3 emit-box-float ;
-
-: emit-float/f ( -- )
- emit-unbox-floats
- $3 $1 $2 %fdiv emit
- ^1 $3 emit-box-float ;
-
-: emit-float-compare ( cc -- )
- emit-unbox-floats
- $3 $1 $2 %fcmp emit
- [ ^1 $3 ] dip %%fboolean emit ;
-
-: emit-float<= ( -- )
- cc<= emit-float-compare ;
-
-: emit-float>= ( -- )
- cc>= emit-float-compare ;
-
-: emit-float< ( -- )
- cc< emit-float-compare ;
-
-: emit-float> ( -- )
- cc> emit-float-compare ;
-
-: emit-float= ( -- )
- cc= emit-float-compare ;
-
-: emit-allot ( vreg size class -- )
- [ tag-number ] [ type-number ] bi %%allot emit ;
-
-: emit-(tuple) ( layout -- )
- [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 tuple tag-number %%set-slot emit ;
-
-: emit-(array) ( n -- )
- [ [ ^1 ] dip 2 + array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 array tag-number %%set-slot emit ;
-
-: emit-(byte-array) ( n -- )
- [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
- [ [ $1 ] dip emit-literal ] bi
- $2 1 emit-literal
- $1 ^1 $2 byte-array tag-number %%set-slot emit ;
-
-! fixnum>bignum
-! bignum>fixnum
-! fixnum+
-! fixnum-
-! getenv, setenv
-! alien accessors
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser prettyprint.backend kernel accessors math
-math.order sequences namespaces arrays assocs ;
-IN: compiler.vops
-
-TUPLE: vreg n ;
-
-: VREG: scan-word vreg boa parsed ; parsing
-
-M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
-
-SYMBOL: vreg-counter
-
-: init-counter ( -- )
- { 0 } clone vreg-counter set ;
-
-: next-vreg ( -- n )
- 0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
-
-: emit ( ... class -- ) boa , ; inline
-
-! ! ! Instructions. Those prefixed with %% are high level
-! ! ! instructions eliminated during the elaboration phase.
-TUPLE: vop ;
-
-! Instruction which does not touch vregs.
-TUPLE: nullary-op < vop ;
-
-! Does nothing
-TUPLE: nop < nullary-op ;
-
-: nop ( -- vop ) T{ nop } ;
-
-: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
-
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: flushable-op < vop out ;
-
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: pure-op < flushable-op ;
-
-! Instruction only used for its side effect, produces no values
-TUPLE: effect-op < vop in ;
-
-TUPLE: binary-op < pure-op in1 in2 ;
-
-: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
-
-: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
-
-TUPLE: unary-op < pure-op in ;
-
-! Merge point; out is a sequence of vregs in a sequence of
-! sequences of vregs
-TUPLE: %phi < pure-op in ;
-
-! Integer, floating point, condition register copy
-TUPLE: %copy < unary-op ;
-
-! Constants
-TUPLE: constant-op < pure-op value ;
-
-TUPLE: %iconst < constant-op ; ! Integer
-TUPLE: %fconst < constant-op ; ! Float
-TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
-
-! Load address of literal table into out
-TUPLE: %literal-table < pure-op ;
-
-! Load object literal from table.
-TUPLE: %literal < unary-op object ;
-
-! Read/write ops: candidates for alias analysis
-TUPLE: read-op < flushable-op ;
-TUPLE: write-op < effect-op ;
-
-! Stack shuffling
-SINGLETON: %data
-SINGLETON: %retain
-
-TUPLE: %peek < read-op n stack ;
-TUPLE: %replace < write-op n stack ;
-TUPLE: %height < nullary-op n stack ;
-
-: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
-
-TUPLE: commutative-op < binary-op ;
-
-! Integer arithmetic
-TUPLE: %iadd < commutative-op ;
-TUPLE: %isub < binary-op ;
-TUPLE: %imul < commutative-op ;
-TUPLE: %idiv < binary-op ;
-TUPLE: %imod < binary-op ;
-TUPLE: %icmp < binary-op ;
-
-! Bitwise ops
-TUPLE: %not < unary-op ;
-TUPLE: %and < commutative-op ;
-TUPLE: %or < commutative-op ;
-TUPLE: %xor < commutative-op ;
-TUPLE: %shl < binary-op ;
-TUPLE: %shr < binary-op ;
-TUPLE: %sar < binary-op ;
-
-! Float arithmetic
-TUPLE: %fadd < commutative-op ;
-TUPLE: %fsub < binary-op ;
-TUPLE: %fmul < commutative-op ;
-TUPLE: %fdiv < binary-op ;
-TUPLE: %fcmp < binary-op ;
-
-! Float/integer conversion
-TUPLE: %f>i < unary-op ;
-TUPLE: %i>f < unary-op ;
-
-! Float boxing/unboxing
-TUPLE: %%box-float < unary-op ;
-TUPLE: %%unbox-float < unary-op ;
-
-! High level slot accessors for alias analysis
-! tag is f; if its not f, we can generate a faster sequence
-TUPLE: %%slot < read-op obj slot tag ;
-TUPLE: %%set-slot < write-op obj slot tag ;
-
-TUPLE: %write-barrier < effect-op ;
-
-! Memory
-TUPLE: %load < unary-op ;
-TUPLE: %store < effect-op addr ;
-
-! Control flow; they jump to either the first or second successor
-! of the BB
-
-! Unconditional transfer to first successor
-TUPLE: %b < nullary-op ;
-
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: evaluate-cc ( result cc -- ? )
- H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
-
-TUPLE: cond-branch < effect-op code ;
-
-TUPLE: %bi < cond-branch ;
-TUPLE: %bf < cond-branch ;
-
-! Convert condition register to a boolean
-TUPLE: boolean-op < unary-op code ;
-
-TUPLE: %%iboolean < boolean-op ;
-TUPLE: %%fboolean < boolean-op ;
-
-! Dispatch table, jumps to successor 0..n-1 depending value of
-! in, which must be in the range [0,n)
-TUPLE: %dispatch < effect-op ;
-
-! Procedures
-TUPLE: %return < nullary-op ;
-TUPLE: %prolog < nullary-op ;
-TUPLE: %epilog < nullary-op ;
-TUPLE: %jump < nullary-op word ;
-TUPLE: %call < nullary-op word ;
-
-! Heap allocation
-TUPLE: %%allot < flushable-op size tag type ;
projects / factor.git / commitdiff