diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 8ea182c108..bee7884e81 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -9,12 +9,12 @@ compiler.tree.builder compiler.tree.combinators compiler.tree.propagation.info compiler.cfg +compiler.cfg.hats +compiler.cfg.stacks compiler.cfg.iterator compiler.cfg.registers +compiler.cfg.intrinsics compiler.cfg.instructions -compiler.cfg.builder.hats -compiler.cfg.builder.calls -compiler.cfg.builder.stacks compiler.alien ; IN: compiler.cfg.builder diff --git a/basis/compiler/cfg/builder/calls/calls.factor b/basis/compiler/cfg/builder/calls/calls.factor deleted file mode 100644 index 9337bb17cc..0000000000 --- a/basis/compiler/cfg/builder/calls/calls.factor +++ /dev/null @@ -1,361 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: qualified kernel words sequences layouts namespaces -accessors fry arrays byte-arrays locals math combinators alien -classes.algebra cpu.architecture compiler.tree.propagation.info -compiler.cfg.registers -compiler.cfg.instructions -compiler.cfg.builder.hats -compiler.cfg.builder.stacks ; -QUALIFIED: compiler.intrinsics -QUALIFIED: kernel.private -QUALIFIED: slots.private -QUALIFIED: math.private -QUALIFIED: alien.accessors -IN: compiler.cfg.builder.calls - -{ - kernel.private:tag - math.private:fixnum+fast - math.private:fixnum-fast - math.private:fixnum-bitand - math.private:fixnum-bitor - math.private:fixnum-bitxor - math.private:fixnum-shift-fast - math.private:fixnum-bitnot - math.private:fixnum*fast - math.private:fixnum< - math.private:fixnum<= - math.private:fixnum>= - math.private:fixnum> - math.private:bignum>fixnum - math.private:fixnum>bignum - eq? - compiler.intrinsics:(slot) - compiler.intrinsics:(set-slot) - compiler.intrinsics:(tuple) - compiler.intrinsics:(array) - compiler.intrinsics:(byte-array) - compiler.intrinsics:(complex) - compiler.intrinsics:(ratio) - compiler.intrinsics:(wrapper) - compiler.intrinsics:(write-barrier) - alien.accessors:alien-unsigned-1 - alien.accessors:set-alien-unsigned-1 - alien.accessors:alien-signed-1 - alien.accessors:set-alien-signed-1 - alien.accessors:alien-unsigned-2 - alien.accessors:set-alien-unsigned-2 - alien.accessors:alien-signed-2 - alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell - alien.accessors:set-alien-cell -} [ t "intrinsic" set-word-prop ] each - -: enable-alien-4-intrinsics ( -- ) - { - alien.accessors:alien-unsigned-4 - alien.accessors:set-alien-unsigned-4 - alien.accessors:alien-signed-4 - alien.accessors:set-alien-signed-4 - } [ t "intrinsic" set-word-prop ] each ; - -: enable-float-intrinsics ( -- ) - { - math.private:float+ - math.private:float- - math.private:float* - math.private:float/f - math.private:fixnum>float - math.private:float>fixnum - alien.accessors:alien-float - alien.accessors:set-alien-float - alien.accessors:alien-double - alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; - -: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; - -: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; - -: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; - -: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; - -: emit-tag ( -- ) - phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ; - -: (emit-slot) ( infos -- dst ) - [ 2phantom-pop ] [ third literal>> ] bi* - ^^slot ; - -: (emit-slot-imm) ( infos -- dst ) - 1 phantom-drop - [ phantom-pop ^^offset>slot ] - [ [ second literal>> ] [ third literal>> ] bi ] bi* - ^^slot-imm ; - -: value-info-small-tagged? ( value-info -- ? ) - dup literal?>> [ literal>> small-tagged? ] [ drop f ] if ; - -: emit-slot ( node -- ) - node-input-infos - dup second value-info-small-tagged? - [ (emit-slot-imm) ] [ (emit-slot) ] if - phantom-push ; - -: (emit-set-slot) ( infos -- ) - [ 3phantom-pop ] [ fourth literal>> ] bi* - ^^set-slot ; - -: (emit-set-slot-imm) ( infos -- ) - 1 phantom-drop - [ 2phantom-pop ^^offset>slot ] - [ [ third literal>> ] [ fourth literal>> ] bi ] bi* - ##set-slot-imm ; - -: emit-set-slot ( node -- ) - 1 phantom-drop - node-input-infos - dup third value-info-small-tagged? - [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ; - -: (emit-fixnum-imm-op) ( infos insn -- dst ) - 1 phantom-drop - [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri* - call ; inline - -: (emit-fixnum-op) ( insn -- dst ) - [ 2phantom-pop ] dip call ; inline - -:: emit-fixnum-op ( node insn imm-insn -- ) - [let | infos [ node node-input-infos ] | - infos second value-info-small-tagged? - [ infos imm-insn (emit-fixnum-imm-op) ] - [ insn (emit-fixnum-op) ] - if - phantom-push - ] ; inline - -: emit-primitive ( node -- ) - word>> ##simple-stack-frame ##call ; - -: emit-fixnum-shift-fast ( node -- ) - dup node-input-infos dup second value-info-small-tagged? [ - nip - [ 1 phantom-drop phantom-pop ] dip - second literal>> dup sgn { - { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } - { 0 [ drop ] } - { 1 [ ^^shl-imm ] } - } case - phantom-push - ] [ drop emit-primitive ] if ; - -: emit-fixnum-bitnot ( -- ) - phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ; - -: (emit-fixnum*fast) ( -- dst ) - 2phantom-pop ^^untag-fixnum ^^mul ; - -: (emit-fixnum*fast-imm) ( infos -- dst ) - 1 phantom-drop - [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ; - -: emit-fixnum*fast ( node -- ) - node-input-infos - dup second value-info-small-tagged? - [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if - phantom-push ; - -: emit-fixnum-comparison ( node cc -- ) - [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi - emit-fixnum-op ; - -: emit-bignum>fixnum ( -- ) - phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ; - -: emit-fixnum>bignum ( -- ) - phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ; - -: emit-float-op ( insn -- ) - [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float - phantom-push ; inline - -: emit-float-comparison ( cc -- ) - [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float - phantom-push ; inline - -: emit-float>fixnum ( -- ) - phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ; - -: emit-fixnum>float ( -- ) - phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ; - -: pop-literal ( node -- n ) - 1 phantom-drop dup in-d>> first node-value-info literal>> ; - -: emit-allot ( size type tag -- ) - ^^allot [ fresh-object ] [ phantom-push ] bi ; - -: emit-write-barrier ( -- ) - phantom-pop dup fresh-object? [ drop ] [ ^^write-barrier ] if ; - -: (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) - 1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; - -: (prepare-alien-accessor) ( class -- offset-vreg ) - [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; - -: prepare-alien-accessor ( infos -- offset-vreg ) - [ second class>> ] [ first ] bi - dup value-info-small-tagged? [ - 1 phantom-drop - literal>> (prepare-alien-accessor-imm) - ] [ drop (prepare-alien-accessor) ] if ; - -:: inline-alien ( node quot test -- ) - [let | infos [ node node-input-infos ] | - infos test call - [ infos prepare-alien-accessor quot call ] - [ node emit-primitive ] - if - ] ; inline - -: inline-alien-getter? ( infos -- ? ) - [ first class>> c-ptr class<= ] - [ second class>> fixnum class<= ] - bi and ; - -: inline-alien-getter ( node quot -- ) - '[ @ phantom-push ] - [ inline-alien-getter? ] inline-alien ; inline - -: inline-alien-setter? ( infos class -- ? ) - '[ first class>> _ class<= ] - [ second class>> c-ptr class<= ] - [ third class>> fixnum class<= ] - tri and and ; - -: inline-alien-integer-setter ( node quot -- ) - '[ phantom-pop ^^untag-fixnum @ ] - [ fixnum inline-alien-setter? ] - inline-alien ; inline - -: inline-alien-cell-setter ( node quot -- ) - [ dup node-input-infos first class>> ] dip - '[ phantom-pop _ ^^unbox-c-ptr @ ] - [ pinned-c-ptr inline-alien-setter? ] - inline-alien ; inline - -: inline-alien-float-setter ( node quot -- ) - '[ phantom-pop ^^unbox-float @ ] - [ float inline-alien-setter? ] - inline-alien ; inline - -: emit-alien-unsigned-getter ( node n -- ) - '[ - _ { - { 1 [ ^^alien-unsigned-1 ] } - { 2 [ ^^alien-unsigned-2 ] } - { 4 [ ^^alien-unsigned-4 ] } - } case ^^tag-fixnum - ] inline-alien-getter ; - -: emit-alien-signed-getter ( node n -- ) - '[ - _ { - { 1 [ ^^alien-signed-1 ] } - { 2 [ ^^alien-signed-2 ] } - { 4 [ ^^alien-signed-4 ] } - } case ^^tag-fixnum - ] inline-alien-getter ; - -: emit-alien-integer-setter ( node n -- ) - '[ - _ { - { 1 [ ##set-alien-integer-1 ] } - { 2 [ ##set-alien-integer-2 ] } - { 4 [ ##set-alien-integer-4 ] } - } case - ] inline-alien-integer-setter ; - -: emit-alien-cell-getter ( node -- ) - [ ^^alien-cell ^^box-alien ] inline-alien-getter ; - -: emit-alien-cell-setter ( node -- ) - [ ##set-alien-cell ] inline-alien-cell-setter ; - -: emit-alien-float-getter ( node reg-class -- ) - '[ - _ { - { single-float-regs [ ^^alien-float ] } - { double-float-regs [ ^^alien-double ] } - } case ^^box-float - ] inline-alien-getter ; - -: emit-alien-float-setter ( node reg-class -- ) - '[ - _ { - { single-float-regs [ ##set-alien-float ] } - { double-float-regs [ ##set-alien-double ] } - } case - ] inline-alien-float-setter ; - -: emit-intrinsic ( node word -- ) - { - { \ kernel.private:tag [ drop emit-tag ] } - { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } - { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } - { \ math.private:fixnum*fast [ emit-fixnum*fast ] } - { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } - { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } - { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } - { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } - { \ eq? [ cc= emit-fixnum-comparison ] } - { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } - { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } - { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } - { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } - { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } - { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { \ math.private:float< [ drop cc< emit-float-comparison ] } - { \ math.private:float<= [ drop cc<= emit-float-comparison ] } - { \ math.private:float>= [ drop cc>= emit-float-comparison ] } - { \ math.private:float> [ drop cc> emit-float-comparison ] } - { \ math.private:float= [ drop cc> emit-float-comparison ] } - { \ math.private:float>fixnum [ drop emit-float>fixnum ] } - { \ math.private:fixnum>float [ drop emit-fixnum>float ] } - { \ compiler.intrinsics:(slot) [ emit-slot ] } - { \ compiler.intrinsics:(set-slot) [ emit-set-slot ] } - { \ compiler.intrinsics:(tuple) [ pop-literal 2 + cells tuple tuple emit-allot ] } - { \ compiler.intrinsics:(array) [ pop-literal 2 + cells array object emit-allot ] } - { \ compiler.intrinsics:(byte-array) [ pop-literal 2 cells + byte-array object emit-allot ] } - { \ compiler.intrinsics:(complex) [ drop 3 cells complex complex emit-allot ] } - { \ compiler.intrinsics:(ratio) [ drop 3 cells ratio ratio emit-allot ] } - { \ compiler.intrinsics:(wrapper) [ drop 2 cells wrapper object emit-allot ] } - { \ compiler.intrinsics:(write-barrier) [ drop emit-write-barrier ] } - { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } - { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } - { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } - { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } - { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } - { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } - { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] } - { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] } - { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] } - { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] } - } case ; diff --git a/basis/compiler/cfg/builder/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor similarity index 78% rename from basis/compiler/cfg/builder/hats/hats.factor rename to basis/compiler/cfg/hats/hats.factor index d8e4dc613c..77b10b5e9f 100644 --- a/basis/compiler/cfg/builder/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -1,8 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel layouts cpu.architecture compiler.cfg.registers +USING: arrays byte-arrays kernel layouts math namespaces +sequences classes.tuple cpu.architecture compiler.cfg.registers compiler.cfg.instructions ; -IN: compiler.cfg.builder.hats +IN: compiler.cfg.hats + +! 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? ; : i int-regs next-vreg ; inline : ^^i i dup ; inline @@ -45,8 +53,11 @@ IN: compiler.cfg.builder.hats : ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline : ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline : ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline -: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline -: ^^write-barrier ( src -- ) i i ##write-barrier ; inline +: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline +: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline +: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline +: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline +: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline : ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline : ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline @@ -65,3 +76,5 @@ IN: compiler.cfg.builder.hats : ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline : ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline +: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline +: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index da79782aaf..17b9728243 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -88,6 +88,9 @@ INSN: ##shr-imm < ##binary-imm ; INSN: ##sar-imm < ##binary-imm ; INSN: ##not < ##unary ; +: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline +: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline + ! Bignum/integer conversion INSN: ##integer>bignum < ##unary/temp ; INSN: ##bignum>integer < ##unary/temp ; @@ -141,7 +144,7 @@ INSN: ##set-alien-float < ##alien-setter ; INSN: ##set-alien-double < ##alien-setter ; ! Memory allocation -INSN: ##allot < ##flushable size type tag { temp vreg } ; +INSN: ##allot < ##flushable size class { temp vreg } ; INSN: ##write-barrier < ##effect card# table ; INSN: ##gc ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor new file mode 100644 index 0000000000..9ab013f04b --- /dev/null +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel sequences alien math classes.algebra +fry locals combinators cpu.architecture +compiler.tree.propagation.info +compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions +compiler.cfg.intrinsics.utilities ; +IN: compiler.cfg.intrinsics.alien + +: (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) + 1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; + +: (prepare-alien-accessor) ( class -- offset-vreg ) + [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ; + +: prepare-alien-accessor ( infos -- offset-vreg ) + [ second class>> ] [ first ] bi + dup value-info-small-tagged? [ + 1 phantom-drop + literal>> (prepare-alien-accessor-imm) + ] [ drop (prepare-alien-accessor) ] if ; + +:: inline-alien ( node quot test -- ) + [let | infos [ node node-input-infos ] | + infos test call + [ infos prepare-alien-accessor quot call ] + [ node emit-primitive ] + if + ] ; inline + +: inline-alien-getter? ( infos -- ? ) + [ first class>> c-ptr class<= ] + [ second class>> fixnum class<= ] + bi and ; + +: inline-alien-getter ( node quot -- ) + '[ @ phantom-push ] + [ inline-alien-getter? ] inline-alien ; inline + +: inline-alien-setter? ( infos class -- ? ) + '[ first class>> _ class<= ] + [ second class>> c-ptr class<= ] + [ third class>> fixnum class<= ] + tri and and ; + +: inline-alien-integer-setter ( node quot -- ) + '[ phantom-pop ^^untag-fixnum @ ] + [ fixnum inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-cell-setter ( node quot -- ) + [ dup node-input-infos first class>> ] dip + '[ phantom-pop _ ^^unbox-c-ptr @ ] + [ pinned-c-ptr inline-alien-setter? ] + inline-alien ; inline + +: inline-alien-float-setter ( node quot -- ) + '[ phantom-pop ^^unbox-float @ ] + [ float inline-alien-setter? ] + inline-alien ; inline + +: emit-alien-unsigned-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-unsigned-1 ] } + { 2 [ ^^alien-unsigned-2 ] } + { 4 [ ^^alien-unsigned-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-signed-getter ( node n -- ) + '[ + _ { + { 1 [ ^^alien-signed-1 ] } + { 2 [ ^^alien-signed-2 ] } + { 4 [ ^^alien-signed-4 ] } + } case ^^tag-fixnum + ] inline-alien-getter ; + +: emit-alien-integer-setter ( node n -- ) + '[ + _ { + { 1 [ ##set-alien-integer-1 ] } + { 2 [ ##set-alien-integer-2 ] } + { 4 [ ##set-alien-integer-4 ] } + } case + ] inline-alien-integer-setter ; + +: emit-alien-cell-getter ( node -- ) + [ ^^alien-cell ^^box-alien ] inline-alien-getter ; + +: emit-alien-cell-setter ( node -- ) + [ ##set-alien-cell ] inline-alien-cell-setter ; + +: emit-alien-float-getter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ^^alien-float ] } + { double-float-regs [ ^^alien-double ] } + } case ^^box-float + ] inline-alien-getter ; + +: emit-alien-float-setter ( node reg-class -- ) + '[ + _ { + { single-float-regs [ ##set-alien-float ] } + { double-float-regs [ ##set-alien-double ] } + } case + ] inline-alien-float-setter ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor new file mode 100644 index 0000000000..a371f071cc --- /dev/null +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.order sequences accessors arrays +byte-arrays layouts classes.tuple.private fry locals +compiler.tree.propagation.info compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.stacks ; +IN: compiler.cfg.intrinsics.allot + +: ##set-slots ( regs obj class -- ) + '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ; + +: emit-simple-allot ( node -- ) + [ in-d>> length ] [ node-output-infos first class>> ] bi + [ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri + [ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ; + +: tuple-slot-regs ( layout -- vregs ) + [ size>> phantom-load ] [ ^^load-literal ] bi prefix ; + +:: emit- ( node -- ) + [let | layout [ node node-input-infos peek literal>> ] | + layout tuple-layout? [ + 1 phantom-drop + layout tuple-slot-regs + layout size>> ^^allot-tuple + tuple ##set-slots + ] [ node emit-primitive ] if + ] ; + +: store-initial-element ( elt reg len -- ) + [ 2 + object tag-number ##set-slot-imm ] with with each ; + +: expand-? ( obj -- ? ) + dup integer? [ 0 8 between? ] [ drop f ] if ; + +:: emit- ( node -- ) + [let | len [ node node-input-infos first literal>> ] | + len expand-? [ + [let | elt [ phantom-pop ] + reg [ len ^^allot-array ] | + 1 phantom-drop + elt reg len store-initial-element + reg phantom-push + ] + ] [ node emit-primitive ] if + ] ; + +: expand-? ( obj -- ? ) + dup integer? [ 0 32 between? ] [ drop f ] if ; + +: bytes>cells ( m -- n ) cell align cell /i ; + +:: emit- ( node -- ) + [let | len [ node node-input-infos first literal>> ] | + len expand-? [ + [let | elt [ 0 ^^load-literal ] + reg [ len ^^allot-byte-array ] | + 1 phantom-drop + elt reg len bytes>cells store-initial-element + reg phantom-push + ] + ] [ node emit-primitive ] if + ] ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor new file mode 100644 index 0000000000..7791edb727 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences accessors layouts kernel math namespaces +combinators fry locals +compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats +compiler.cfg.intrinsics.utilities ; +IN: compiler.cfg.intrinsics.fixnum + +: (emit-fixnum-imm-op) ( infos insn -- dst ) + 1 phantom-drop + [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri* + call ; inline + +: (emit-fixnum-op) ( insn -- dst ) + [ 2phantom-pop ] dip call ; inline + +:: emit-fixnum-op ( node insn imm-insn -- ) + [let | infos [ node node-input-infos ] | + infos second value-info-small-tagged? + [ infos imm-insn (emit-fixnum-imm-op) ] + [ insn (emit-fixnum-op) ] + if + phantom-push + ] ; inline + +: emit-fixnum-shift-fast ( node -- ) + dup node-input-infos dup second value-info-small-tagged? [ + nip + [ 1 phantom-drop phantom-pop ] dip + second literal>> dup sgn { + { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } + { 0 [ drop ] } + { 1 [ ^^shl-imm ] } + } case + phantom-push + ] [ drop emit-primitive ] if ; + +: emit-fixnum-bitnot ( -- ) + phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ; + +: (emit-fixnum*fast) ( -- dst ) + 2phantom-pop ^^untag-fixnum ^^mul ; + +: (emit-fixnum*fast-imm) ( infos -- dst ) + 1 phantom-drop + [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ; + +: emit-fixnum*fast ( node -- ) + node-input-infos + dup second value-info-small-tagged? + [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if + phantom-push ; + +: emit-fixnum-comparison ( node cc -- ) + [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi + emit-fixnum-op ; + +: emit-bignum>fixnum ( -- ) + phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ; + +: emit-fixnum>bignum ( -- ) + phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ; diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor new file mode 100644 index 0000000000..24bb56d237 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel compiler.cfg.stacks compiler.cfg.hats ; +IN: compiler.cfg.intrinsics.float + +: emit-float-op ( insn -- ) + [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float + phantom-push ; inline + +: emit-float-comparison ( cc -- ) + [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float + phantom-push ; inline + +: emit-float>fixnum ( -- ) + phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ; + +: emit-fixnum>float ( -- ) + phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..0774eff335 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -0,0 +1,137 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: qualified kernel words sequences layouts namespaces +accessors fry arrays byte-arrays locals math math.order +combinators alien classes.algebra cpu.architecture +compiler.tree.propagation.info +compiler.cfg.hats +compiler.cfg.stacks +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.intrinsics.alien +compiler.cfg.intrinsics.allot +compiler.cfg.intrinsics.fixnum +compiler.cfg.intrinsics.float +compiler.cfg.intrinsics.slots ; +QUALIFIED: kernel.private +QUALIFIED: slots.private +QUALIFIED: classes.tuple.private +QUALIFIED: math.private +QUALIFIED: alien.accessors +IN: compiler.cfg.intrinsics + +{ + kernel.private:tag + math.private:fixnum+fast + math.private:fixnum-fast + math.private:fixnum-bitand + math.private:fixnum-bitor + math.private:fixnum-bitxor + math.private:fixnum-shift-fast + math.private:fixnum-bitnot + math.private:fixnum*fast + math.private:fixnum< + math.private:fixnum<= + math.private:fixnum>= + math.private:fixnum> + math.private:bignum>fixnum + math.private:fixnum>bignum + eq? + slots.private:slot + slots.private:set-slot + classes.tuple.private: + + + math.private: + math.private: + + alien.accessors:alien-unsigned-1 + alien.accessors:set-alien-unsigned-1 + alien.accessors:alien-signed-1 + alien.accessors:set-alien-signed-1 + alien.accessors:alien-unsigned-2 + alien.accessors:set-alien-unsigned-2 + alien.accessors:alien-signed-2 + alien.accessors:set-alien-signed-2 + alien.accessors:alien-cell + alien.accessors:set-alien-cell +} [ t "intrinsic" set-word-prop ] each + +: enable-alien-4-intrinsics ( -- ) + { + alien.accessors:alien-unsigned-4 + alien.accessors:set-alien-unsigned-4 + alien.accessors:alien-signed-4 + alien.accessors:set-alien-signed-4 + } [ t "intrinsic" set-word-prop ] each ; + +: enable-float-intrinsics ( -- ) + { + math.private:float+ + math.private:float- + math.private:float* + math.private:float/f + math.private:fixnum>float + math.private:float>fixnum + alien.accessors:alien-float + alien.accessors:set-alien-float + alien.accessors:alien-double + alien.accessors:set-alien-double + } [ t "intrinsic" set-word-prop ] each ; + +: emit-intrinsic ( node word -- ) + { + { \ kernel.private:tag [ drop emit-tag ] } + { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] } + { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } + { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } + { \ math.private:fixnum*fast [ emit-fixnum*fast ] } + { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } + { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } + { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } + { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } + { \ eq? [ cc= emit-fixnum-comparison ] } + { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } + { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } + { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } + { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } + { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } + { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } + { \ math.private:float< [ drop cc< emit-float-comparison ] } + { \ math.private:float<= [ drop cc<= emit-float-comparison ] } + { \ math.private:float>= [ drop cc>= emit-float-comparison ] } + { \ math.private:float> [ drop cc> emit-float-comparison ] } + { \ math.private:float= [ drop cc> emit-float-comparison ] } + { \ math.private:float>fixnum [ drop emit-float>fixnum ] } + { \ math.private:fixnum>float [ drop emit-fixnum>float ] } + { \ slots.private:slot [ emit-slot ] } + { \ slots.private:set-slot [ emit-set-slot ] } + { \ classes.tuple.private: [ emit- ] } + { \ [ emit- ] } + { \ [ emit- ] } + { \ math.private: [ emit-simple-allot ] } + { \ math.private: [ emit-simple-allot ] } + { \ [ emit-simple-allot ] } + { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] } + { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] } + { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] } + { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] } + { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] } + { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] } + { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] } + { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] } + { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] } + } case ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor new file mode 100644 index 0000000000..d2e2e95d0d --- /dev/null +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: layouts namespaces kernel accessors sequences +classes.algebra compiler.tree.propagation.info +compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.intrinsics.utilities ; +IN: compiler.cfg.intrinsics.slots + +: emit-tag ( -- ) + phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ; + +: value-tag ( info -- n ) class>> class-tag ; inline + +: (emit-slot) ( infos -- dst ) + [ 2phantom-pop ] [ first value-tag ] bi* + ^^slot ; + +: (emit-slot-imm) ( infos -- dst ) + 1 phantom-drop + [ phantom-pop ^^offset>slot ] + [ [ second literal>> ] [ first value-tag ] bi ] bi* + ^^slot-imm ; + +: emit-slot ( node -- ) + dup node-input-infos + dup first value-tag [ + nip + dup second value-info-small-tagged? + [ (emit-slot-imm) ] [ (emit-slot) ] if + phantom-push + ] [ drop emit-primitive ] if ; + +: (emit-set-slot) ( infos -- obj-reg ) + [ 3phantom-pop [ tuck ] dip ^^offset>slot ] + [ second value-tag ] + bi* ^^set-slot ; + +: (emit-set-slot-imm) ( infos -- obj-reg ) + 1 phantom-drop + [ 2phantom-pop tuck ] + [ [ third literal>> ] [ second value-tag ] bi ] bi* + ##set-slot-imm ; + +: emit-set-slot ( node -- ) + dup node-input-infos + dup second value-tag [ + nip + 1 phantom-drop + [ + dup third value-info-small-tagged? + [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if + ] [ first class>> immediate class<= ] bi + [ drop ] [ ^^write-barrier ] if + ] [ drop emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor new file mode 100644 index 0000000000..5540e3316a --- /dev/null +++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math layouts cpu.architecture ; +IN: compiler.cfg.intrinsics.utilities + +: value-info-small-tagged? ( value-info -- ? ) + literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 88d7bcdbcf..1eea66f523 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -272,7 +272,6 @@ USING: math.private compiler.cfg.debugger ; T{ vreg f int-regs 1 } 40 array - object T{ vreg f int-regs 2 } f } clone diff --git a/basis/compiler/cfg/builder/stacks/authors.txt b/basis/compiler/cfg/stacks/authors.txt similarity index 100% rename from basis/compiler/cfg/builder/stacks/authors.txt rename to basis/compiler/cfg/stacks/authors.txt diff --git a/basis/compiler/cfg/builder/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor similarity index 91% rename from basis/compiler/cfg/builder/stacks/stacks.factor rename to basis/compiler/cfg/stacks/stacks.factor index e1119e18d6..73261e0e42 100755 --- a/basis/compiler/cfg/builder/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -6,25 +6,14 @@ quotations sequences system vectors words effects alien byte-arrays accessors sets math.order combinators.short-circuit cpu.architecture compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.builder.hats ; -IN: compiler.cfg.builder.stacks +compiler.cfg.hats ; +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? ; - -! 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? ; ! A compile-time stack -TUPLE: phantom-stack height stack ; +TUPLE: phantom-stack { height integer } { stack vector } ; M: phantom-stack clone call-next-method [ clone ] change-stack ; @@ -32,11 +21,11 @@ M: phantom-stack clone GENERIC: finalize-height ( stack -- ) : new-phantom-stack ( class -- stack ) - >r 0 V{ } clone r> boa ; inline + new V{ } clone >>stack ; inline : (loc) ( m stack -- n ) #! Utility for methods on - height>> - ; + height>> - ; inline : (finalize-height) ( stack word -- ) #! We consolidate multiple stack height changes until the @@ -207,3 +196,6 @@ M: loc lazy-store : 3phantom-pop ( -- vreg1 vreg2 vreg3 ) 3 phantom-load first3 ; + +: emit-primitive ( node -- ) + finalize-phantoms word>> ##simple-stack-frame ##call ; diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor deleted file mode 100644 index 2ce01d6659..0000000000 --- a/basis/compiler/intrinsics/intrinsics.factor +++ /dev/null @@ -1,49 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple classes.tuple.private math arrays -byte-arrays words stack-checker.known-words ; -IN: compiler.intrinsics - -ERROR: missing-intrinsic ; - -: (tuple) ( n -- tuple ) missing-intrinsic ; - -\ (tuple) { tuple-layout } { tuple } define-primitive -\ (tuple) make-flushable - -: (array) ( n -- array ) missing-intrinsic ; - -\ (array) { integer } { array } define-primitive -\ (array) make-flushable - -: (byte-array) ( n -- byte-array ) missing-intrinsic ; - -\ (byte-array) { integer } { byte-array } define-primitive -\ (byte-array) make-flushable - -: (ratio) ( -- ratio ) missing-intrinsic ; - -\ (ratio) { } { ratio } define-primitive -\ (ratio) make-flushable - -: (complex) ( -- complex ) missing-intrinsic ; - -\ (complex) { } { complex } define-primitive -\ (complex) make-flushable - -: (wrapper) ( -- wrapper ) missing-intrinsic ; - -\ (wrapper) { } { wrapper } define-primitive -\ (wrapper) make-flushable - -: (slot) ( obj n tag# -- val ) missing-intrinsic ; - -\ (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 ; - -\ (write-barrier) { object } { } define-primitive diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 5b09cfab63..49f2eb0281 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,10 +1,6 @@ ! 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.private math.order memoize -classes.builtin classes.tuple.private classes.algebra -slots.private combinators layouts byte-arrays alien.accessors -compiler.intrinsics +USING: kernel accessors sequences words memoize classes.builtin compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -15,7 +11,7 @@ IN: compiler.tree.finalization ! See the comment in compiler.tree.late-optimizations. ! This pass runs after propagation, so that it can expand -! built-in type predicates and memory allocation; these cannot +! built-in type predicates; these cannot ! be expanded before propagation since we need to see 'fixnum?' ! instead of 'tag 0 eq?' and so on, for semantic reasoning. ! We also delete empty stack shuffles and copies to facilitate @@ -43,123 +39,7 @@ MEMO: builtin-predicate-expansion ( word -- nodes ) : expand-builtin-predicate ( #call -- nodes ) word>> builtin-predicate-expansion ; -: expand-tuple-boa? ( #call -- ? ) - dup word>> \ eq? [ - last-literal tuple-layout? - ] [ drop f ] if ; - -MEMO: (tuple-boa-expansion) ( n -- nodes ) - [ - [ '[ _ (tuple) ] % ] - [ - [ 2 + ] map - [ '[ [ _ 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) - [ over 1 set-slot ] splice-final append ; - -: expand-tuple-boa ( #call -- node ) - last-literal tuple-boa-expansion ; - -MEMO: -expansion ( n -- quot ) - [ - [ swap (array) ] % - [ '[ _ over 1 set-slot ] % ] - [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi - \ nip , - ] [ ] make splice-final ; - -: expand-? ( #call -- ? ) - dup word>> \ eq? [ - first-literal dup integer? - [ 0 8 between? ] [ drop f ] if - ] [ drop f ] if ; - -: expand- ( #call -- node ) - first-literal -expansion ; - -: bytes>cells ( m -- n ) cell align cell /i ; - -MEMO: -expansion ( n -- quot ) - [ - [ (byte-array) ] % - [ '[ _ over 1 set-slot ] % ] - [ - bytes>cells [ - cell * - '[ 0 over _ set-alien-unsigned-cell ] % - ] each - ] bi - ] [ ] make splice-final ; - -: expand-? ( #call -- ? ) - dup word>> \ eq? [ - first-literal dup integer? - [ 0 32 between? ] [ drop f ] if - ] [ drop f ] if ; - -: expand- ( #call -- nodes ) - first-literal -expansion ; - -MEMO: -expansion ( -- quot ) - [ (ratio) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ; - -: expand- ( #call -- nodes ) - drop -expansion ; - -MEMO: -expansion ( -- quot ) - [ (complex) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ; - -: expand- ( #call -- nodes ) - drop -expansion ; - -MEMO: -expansion ( -- quot ) - [ (wrapper) [ 1 set-slot ] keep ] splice-final ; - -: expand- ( #call -- nodes ) - drop -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-? ] [ expand- ] } - { [ dup expand-? ] [ expand- ] } - [ - dup word>> { - { \ [ expand- ] } - { \ [ expand- ] } - { \ [ expand- ] } - { \ set-slot [ expand-set-slot ] } - { \ slot [ expand-slot ] } - [ drop ] - } case - ] - } cond ; + dup builtin-predicate? [ expand-builtin-predicate ] when ; M: node finalize* ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 24115767c3..2152664c4b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -108,7 +108,7 @@ HOOK: %set-alien-cell cpu ( ptr value -- ) HOOK: %set-alien-float cpu ( ptr value -- ) HOOK: %set-alien-double cpu ( ptr value -- ) -HOOK: %allot cpu ( dst size type tag temp -- ) +HOOK: %allot cpu ( dst size class temp -- ) HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %gc cpu ( -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 015b1b8b03..0ae92a0c07 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler cpu.x86.architecture cpu.architecture compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.builder.calls ; +compiler.cfg.builder compiler.cfg.intrinsics ; IN: cpu.x86.32 ! We implement the FFI for Linux, OS X and Windows all at once. diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index e081b80374..6938db2afd 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -6,7 +6,7 @@ slots splitting assocs combinators cpu.x86.assembler cpu.x86.architecture cpu.architecture compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder -compiler.cfg.builder.calls ; +compiler.cfg.intrinsics ; IN: cpu.x86.64 M: x86.64 machine-registers diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 37f827b857..7db725c6a5 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -122,7 +122,7 @@ M:: x86 %integer>bignum ( dst src temp -- ) "end" get JMP "nonzero" resolve-label ! Allocate a bignum - dst 4 cells bignum bignum temp %allot + dst 4 cells bignum temp %allot ! Write length dst 1 bignum@ 2 tag-fixnum MOV ! Test sign @@ -205,7 +205,7 @@ M:: x86 %unbox-any-c-ptr ( dst src dst temp -- ) ] with-scope ; M:: x86 %box-float ( dst src temp -- ) - dst 16 float float temp %allot + dst 16 float temp %allot dst 8 float tag-number - [+] src MOVSD ; : alien@ ( reg n -- op ) cells object tag-number - [+] ; @@ -215,7 +215,7 @@ 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 4 cells alien temp %allot dst 1 alien@ \ f tag-number MOV dst 2 alien@ \ f tag-number MOV ! Store src in alien-offset slot @@ -343,10 +343,10 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ; : store-tagged ( dst tag -- ) tag-number OR ; -M:: x86 %allot ( dst size type tag nursery-ptr -- ) +M:: x86 %allot ( dst size class nursery-ptr -- ) nursery-ptr dst load-allot-ptr - dst type store-header - dst tag store-tagged + dst class store-header + dst class store-tagged nursery-ptr size inc-allot-ptr ; HOOK: %alien-global cpu ( symbol dll register -- )