USING: arrays generic hashtables inference io kernel math
namespaces prettyprint sequences vectors words ;
+! Register allocation
SYMBOL: free-vregs
+: alloc-reg ( -- n )
+ free-vregs get pop ;
+
+: alloc-reg# ( n -- regs )
+ free-vregs [ cut ] change ;
+
+: requested-vregs ( template -- n )
+ 0 [ [ 1+ ] unless ] reduce ;
+
+: template-vreg# ( template template -- n )
+ [ requested-vregs ] 2apply + ;
+
+: alloc-vregs ( template -- template )
+ [ first [ alloc-reg ] unless* ] map ;
+
+: adjust-free-vregs ( seq -- )
+ free-vregs [ diff ] change ;
+
! A data stack location.
TUPLE: ds-loc n ;
: finalize-heights ( -- )
phantoms [ finalize-height ] 2apply ;
-: alloc-reg ( -- n ) free-vregs get pop ;
-
: stack>vreg ( vreg# loc -- operand )
>r <vreg> dup r> %peek ;
used-vregs vregs length reverse diff
>vector free-vregs set ;
-: requested-vregs ( template -- n )
- 0 [ [ 1+ ] unless ] reduce ;
-
-: template-vreg# ( template template -- n )
- [ requested-vregs ] 2apply + ;
-
-: alloc-regs ( template -- template )
- [ [ alloc-reg ] unless* ] map ;
-
-: alloc-reg# ( n -- regs )
- free-vregs [ cut ] change ;
-
: additional-vregs# ( seq seq -- n )
2array phantoms 2array [ [ length ] map ] 2apply v-
0 [ 0 max + ] reduce ;
: stack>vregs ( phantom template -- values )
[
- [ first ] map alloc-regs
- dup length rot phantom-locs
+ alloc-vregs dup length rot phantom-locs
[ stack>vreg ] 2map
] 2keep length neg swap adjust-phantom ;
{ +clobber { } }
} swap hash-union ;
-: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
-
: output-vregs ( -- seq seq )
+output +clobber [ get [ get ] map ] 2apply ;
[ swap member? ] contains-with? ;
: slow-input ( template -- )
+ ! Are we loading stuff from the stack? Then flush out
+ ! remaining vregs, not slurped in by fast-input.
dup empty? [ finalize-contents ] unless
+ ! Do the outputs clash with vregs on the phantom stacks?
+ ! Then we must flush them first.
outputs-clash? [ finalize-contents ] when
phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
+input +scratch [ get [ second get vreg-n ] map ] 2apply
append ;
+: guess-vregs ( -- n )
+ +input get dup { } additional-vregs# +scratch get length + ;
+
+: alloc-scratch ( -- )
+ +scratch get [ alloc-vregs [ <vreg> ] map ] keep
+ phantom-vregs ;
+
: template-inputs ( -- )
- +input get dup { } additional-vregs# ensure-vregs
+ ! Ensure we have enough to hold any new stack elements we
+ ! will read (if any), and scratch.
+ guess-vregs ensure-vregs
+ ! Split the template into available (fast) parts and those
+ ! that require allocating registers and reading the stack
match-template fast-input
used-vregs adjust-free-vregs
slow-input
+ alloc-scratch
input-vregs adjust-free-vregs ;
: template-outputs ( -- )
+++ /dev/null
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: arrays assembler generic hashtables
-inference kernel kernel-internals lists math math-internals
-namespaces sequences words ;
-
-\ slot [
- [
- "obj" get %untag ,
- "n" get "obj" get %slot ,
- ] H{
- { +input { { f "obj" } { f "n" } } }
- { +output { "obj" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ set-slot [
- [
- "obj" get %untag ,
- "val" get "obj" get "slot" get %set-slot ,
- finalize-contents
- "obj" get %write-barrier ,
- ] H{
- { +input { { f "val" } { f "obj" } { f "slot" } } }
- { +clobber { "obj" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ char-slot [
- [
- "n" get "str" get %char-slot ,
- ] H{
- { +input { { f "n" } { f "str" } } }
- { +output { "str" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ set-char-slot [
- [
- "ch" get "str" get "n" get %set-char-slot ,
- ] H{
- { +input { { f "ch" } { f "n" } { f "str" } } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ type [
- [ finalize-contents "in" get %type , ] H{
- { +input { { f "in" } } }
- { +output { "in" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ tag [
- [ "in" get %tag , ] H{
- { +input { { f "in" } } }
- { +output { "in" } }
- } with-template
-] "intrinsic" set-word-prop
-
-: binary-op ( op -- )
- [
- finalize-contents >r "y" get "x" get dup r> execute ,
- ] H{
- { +input { { 0 "x" } { 1 "y" } } }
- { +output { "x" } }
- } with-template ; inline
-
-{
- { fixnum+ %fixnum+ }
- { fixnum- %fixnum- }
- { fixnum/i %fixnum/i }
- { fixnum* %fixnum* }
-} [
- first2 [ binary-op ] curry
- "intrinsic" set-word-prop
-] each
-
-: binary-op-fast ( op -- )
- [
- >r "y" get "x" get dup r> execute ,
- ] H{
- { +input { { f "x" } { f "y" } } }
- { +output { "x" } }
- } with-template ; inline
-
-{
- { fixnum-bitand %fixnum-bitand }
- { fixnum-bitor %fixnum-bitor }
- { fixnum-bitxor %fixnum-bitxor }
- { fixnum+fast %fixnum+fast }
- { fixnum-fast %fixnum-fast }
-} [
- first2 [ binary-op-fast ] curry
- "intrinsic" set-word-prop
-] each
-
-: binary-jump ( label op -- )
- [
- end-basic-block >r >r "y" get "x" get r> r> execute ,
- ] H{
- { +input { { f "x" } { f "y" } } }
- } with-template ; inline
-
-{
- { fixnum<= %jump-fixnum<= }
- { fixnum< %jump-fixnum< }
- { fixnum>= %jump-fixnum>= }
- { fixnum> %jump-fixnum> }
- { eq? %jump-eq? }
-} [
- first2 [ binary-jump ] curry
- "if-intrinsic" set-word-prop
-] each
-
-\ fixnum-mod [
- ! This is not clever. Because of x86, %fixnum-mod is
- ! hard-coded to put its output in vreg 2, which happends to
- ! be EDX there.
- [
- finalize-contents
- T{ vreg f 2 } "out" set
- "y" get "x" get "out" get %fixnum-mod ,
- ] H{
- { +input { { 0 "x" } { 1 "y" } } }
- ! { +scratch { { 2 "out" } } }
- { +output { "out" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ fixnum/mod [
- ! See the remark on fixnum-mod for vreg usage
- [
- finalize-contents
- T{ vreg f 2 } "rem" set
- "y" get "x" get 2array
- "rem" get "x" get 2array %fixnum/mod ,
- ] H{
- { +input { { 0 "x" } { 1 "y" } } }
- ! { +scratch { { 2 "rem" } } }
- { +output { "x" "rem" } }
- } with-template
-] "intrinsic" set-word-prop
-
-\ fixnum-bitnot [
- [ "x" get dup %fixnum-bitnot , ] H{
- { +input { { f "x" } } }
- { +output { "x" } }
- } with-template
-] "intrinsic" set-word-prop
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
-USING: assembler kernel kernel-internals math math-internals
-namespaces sequences ;
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences words ;
: untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
: untag-fixnum ( src dest -- ) tag-bits SRAWI ;
\ tag [
- "in" operand dup tag-mask ANDI
- "in" operand dup tag-fixnum
+ "in" operand "out" operand tag-mask ANDI
+ "out" operand dup tag-fixnum
] H{
{ +input { { f "in" } } }
- { +output { "in" } }
+ { +scratch { { f "out" } } }
+ { +output { "out" } }
} define-intrinsic
: generate-slot ( size quot -- )
{ +output { "obj" } }
} define-intrinsic
+: generate-set-slot ( size quot -- )
+ >r >r
+ ! turn tagged fixnum slot # into an offset, multiple of 4
+ "slot" operand dup tag-bits r> - SRAWI
+ ! compute slot address in 1st input
+ "slot" operand dup "obj" operand ADD
+ ! store new slot value
+ "val" operand "slot" operand r> call ; inline
+
+: generate-write-barrier ( -- )
+ #! Mark the card pointed to by vreg.
+ "obj" operand dup card-bits SRAWI
+ "obj" operand dup 16 ADD
+ "x" operand "obj" operand 0 LBZ
+ "x" operand dup card-mark ORI
+ "x" operand "obj" operand 0 STB ;
+
+\ set-slot [
+ "obj" operand dup untag
+ cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
+] H{
+ { +input { { f "val" } { f "obj" } { f "slot" } } }
+ { +scratch { { f "x" } } }
+ { +clobber { "obj" } }
+} define-intrinsic
+
+\ set-char-slot [
+ ! untag the new value in 0th input
+ "val" operand dup untag-fixnum
+ 1 [ string-offset STH ] generate-set-slot
+] H{
+ { +input { { f "val" } { f "slot" } { f "obj" } } }
+ { +scratch { { f "x" } } }
+ { +clobber { "obj" } }
+} define-intrinsic
+
: define-binary-op ( word op -- )
[ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
{ +input { { f "x" } { f "y" } } }
first2 define-binary-op
] each
+: generate-fixnum-mod
+ #! PowerPC doesn't have a MOD instruction; so we compute
+ #! x-(x/y)*y. Puts the result in "s" operand.
+ "s" operand "r" operand "y" operand MULLW
+ "s" operand "s" operand "x" operand SUBF ;
+
+\ fixnum-mod [
+ ! divide x by y, store result in x
+ "r" operand "x" operand "y" operand DIVW
+ generate-fixnum-mod
+ "x" operand "s" operand MR
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } { f "s" } } }
+ { +output { "x" } }
+} define-intrinsic
+
\ fixnum-bitnot [
"x" operand dup NOT
"x" operand dup untag
first2 define-binary-jump
] each
-! M: %type generate-node ( vop -- )
-! drop
-! <label> "f" set
-! <label> "end" set
-! ! Get the tag
-! 0 input-operand 1 scratch tag-mask ANDI
-! ! Tag the tag
-! 1 scratch 0 scratch tag-fixnum
-! ! Compare with object tag number (3).
-! 0 1 scratch object-tag CMPI
-! ! Jump if the object doesn't store type info in its header
-! "end" get BNE
-! ! It does store type info in its header
-! ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-! 0 0 input-operand object-tag CMPI
-! "f" get BEQ
-! ! The pointer is not equal to 3. Load the object header.
-! 0 scratch 0 input-operand object-tag neg LWZ
-! 0 scratch dup untag
-! "end" get B
-! "f" get save-xt
-! ! The pointer is equal to 3. Load F_TYPE (9).
-! f type tag-bits shift 0 scratch LI
-! "end" get save-xt
-! 0 output-operand 0 scratch MR ;
-!
-! : generate-set-slot ( size quot -- )
-! >r >r
-! ! turn tagged fixnum slot # into an offset, multiple of 4
-! 2 input-operand dup tag-bits r> - SRAWI
-! ! compute slot address in 1st input
-! 2 input-operand dup 1 input-operand ADD
-! ! store new slot value
-! 0 input-operand 2 input-operand r> call ; inline
-!
-! M: %set-slot generate-node ( vop -- )
-! drop cell log2 [ 0 STW ] generate-set-slot ;
-!
-! M: %write-barrier generate-node ( vop -- )
-! #! Mark the card pointed to by vreg.
-! drop
-! 0 input-operand dup card-bits SRAWI
-! 0 input-operand dup 16 ADD
-! 0 scratch 0 input-operand 0 LBZ
-! 0 scratch dup card-mark ORI
-! 0 scratch 0 input-operand 0 STB ;
-!
-! : simple-overflow ( inv word -- )
-! >r >r
-! <label> "end" set
-! "end" get BNO
-! >3-vop< r> execute
-! 0 input-operand dup untag-fixnum
-! 1 input-operand dup untag-fixnum
-! >3-vop< r> execute
-! "s48_long_to_bignum" f compile-c-call
-! ! An untagged pointer to the bignum is now in r3; tag it
-! 0 output-operand dup bignum-tag ORI
-! "end" get save-xt ; inline
-!
-! M: %fixnum+ generate-node ( vop -- )
-! drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-!
-! M: %fixnum- generate-node ( vop -- )
-! drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-!
-! M: %fixnum* generate-node ( vop -- )
-! #! Note that this assumes the output will be in r3.
-! drop
-! <label> "end" set
-! 1 input-operand dup untag-fixnum
-! 0 MTXER
-! 0 scratch 0 input-operand 1 input-operand MULLWO.
-! "end" get BNO
-! 1 scratch 0 input-operand 1 input-operand MULHW
-! 4 1 scratch MR
-! 3 0 scratch MR
-! "s48_fixnum_pair_to_bignum" f compile-c-call
-! ! now we have to shift it by three bits to remove the second
-! ! tag
-! tag-bits neg 4 LI
-! "s48_bignum_arithmetic_shift" f compile-c-call
-! ! An untagged pointer to the bignum is now in r3; tag it
-! 0 output-operand 0 scratch bignum-tag ORI
-! "end" get save-xt
-! 0 output-operand 0 scratch MR ;
-!
-! : generate-fixnum/i
-! #! This VOP is funny. If there is an overflow, it falls
-! #! through to the end, and the result is in 0 output-operand.
-! #! Otherwise it jumps to the "no-overflow" label and the
-! #! result is in 0 scratch.
-! 0 scratch 1 input-operand 0 input-operand DIVW
-! ! if the result is greater than the most positive fixnum,
-! ! which can only ever happen if we do
-! ! most-negative-fixnum -1 /i, then the result is a bignum.
-! <label> "end" set
-! <label> "no-overflow" set
-! most-positive-fixnum 1 scratch LOAD
-! 0 scratch 0 1 scratch CMP
-! "no-overflow" get BLE
-! most-negative-fixnum neg 3 LOAD
-! "s48_long_to_bignum" f compile-c-call
-! 3 dup bignum-tag ORI ;
-!
-! M: %fixnum/i generate-node ( vop -- )
-! #! This has specific vreg requirements.
-! drop
-! generate-fixnum/i
-! "end" get B
-! "no-overflow" get save-xt
-! 0 scratch 0 output-operand tag-fixnum
-! "end" get save-xt ;
-!
-! : generate-fixnum-mod
-! #! PowerPC doesn't have a MOD instruction; so we compute
-! #! x-(x/y)*y. Puts the result in 1 scratch.
-! 1 scratch 0 scratch 0 input-operand MULLW
-! 1 scratch 1 scratch 1 input-operand SUBF ;
-!
-! M: %fixnum-mod generate-node ( vop -- )
-! drop
-! ! divide in2 by in1, store result in out1
-! 0 scratch 1 input-operand 0 input-operand DIVW
-! generate-fixnum-mod
-! 0 output-operand 1 scratch MR ;
-!
-! M: %fixnum/mod generate-node ( vop -- )
-! #! This has specific vreg requirements. Note: if there's an
-! #! overflow, (most-negative-fixnum 1 /mod) the modulus is
-! #! always zero.
-! drop
-! generate-fixnum/i
-! 0 0 output-operand LI
-! "end" get B
-! "no-overflow" get save-xt
-! generate-fixnum-mod
-! 0 scratch 1 output-operand tag-fixnum
-! 0 output-operand 1 scratch MR
-! "end" get save-xt ;
+\ type [
+ <label> "f" set
+ <label> "end" set
+ ! Get the tag
+ "obj" operand "y" operand tag-mask ANDI
+ ! Tag the tag
+ "y" operand "x" operand tag-fixnum
+ ! Compare with object tag number (3).
+ 0 "y" operand object-tag CMPI
+ ! Jump if the object doesn't store type info in its header
+ "end" get BNE
+ ! It does store type info in its header
+ ! Is the pointer itself equal to 3? Then its F_TYPE (9).
+ 0 "obj" operand object-tag CMPI
+ "f" get BEQ
+ ! The pointer is not equal to 3. Load the object header.
+ "x" operand "obj" operand object-tag neg LWZ
+ "x" operand dup untag
+ "end" get B
+ "f" get save-xt
+ ! The pointer is equal to 3. Load F_TYPE (9).
+ f type tag-bits shift "x" operand LI
+ "end" get save-xt
+] H{
+ { +input { { f "obj" } } }
+ { +scratch { { f "x" } { f "y" } } }
+ { +output { "x" } }
+} define-intrinsic
+
+: simple-overflow ( word -- )
+ >r
+ <label> "end" set
+ "end" get BNO
+ { "x" "y" } [ operand ] map prune [ dup untag-fixnum ] each
+ 3 "y" operand "x" operand r> execute
+ "s48_long_to_bignum" f %alien-invoke
+ ! An untagged pointer to the bignum is now in r3; tag it
+ 3 "r" operand bignum-tag ORI
+ "end" get save-xt ; inline
+
+\ fixnum+ [
+ finalize-contents
+ 0 MTXER
+ "r" operand "y" operand "x" operand ADDO.
+ \ ADD simple-overflow
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } } }
+ { +output { "r" } }
+} define-intrinsic
+
+\ fixnum- [
+ finalize-contents
+ 0 MTXER
+ "r" operand "y" operand "x" operand SUBFO.
+ \ SUBF simple-overflow
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } } }
+ { +output { "r" } }
+} define-intrinsic
+
+: ?MR 2dup = [ 2drop ] [ MR ] if ;
+
+\ fixnum* [
+ finalize-contents
+ <label> "end" set
+ "r" operand "x" operand untag-fixnum
+ 0 MTXER
+ 11 "y" operand "r" operand MULLWO.
+ "end" get BNO
+ 4 "y" operand "r" operand MULHW
+ 3 11 ?MR
+ "s48_fixnum_pair_to_bignum" f %alien-invoke
+ ! now we have to shift it by three bits to remove the second
+ ! tag
+ tag-bits neg 4 LI
+ "s48_bignum_arithmetic_shift" f %alien-invoke
+ ! An untagged pointer to the bignum is now in r3; tag it
+ 3 11 bignum-tag ORI
+ "end" get save-xt
+ "s" operand 11 MR
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } { f "s" } } }
+ { +output { "s" } }
+} define-intrinsic
+
+: generate-fixnum/i
+ #! This VOP is funny. If there is an overflow, it falls
+ #! through to the end, and the result is in "x" operand.
+ #! Otherwise it jumps to the "no-overflow" label and the
+ #! result is in "r" operand.
+ <label> "end" set
+ <label> "no-overflow" set
+ "r" operand "x" operand "y" operand DIVW
+ ! if the result is greater than the most positive fixnum,
+ ! which can only ever happen if we do
+ ! most-negative-fixnum -1 /i, then the result is a bignum.
+ most-positive-fixnum "s" operand LOAD
+ "r" operand 0 "s" operand CMP
+ "no-overflow" get BLE
+ most-negative-fixnum neg 3 LOAD
+ "s48_long_to_bignum" f %alien-invoke
+ "x" operand 3 bignum-tag ORI ;
+
+\ fixnum/i [
+ finalize-contents
+ generate-fixnum/i
+ "end" get B
+ "no-overflow" get save-xt
+ "r" operand "x" operand tag-fixnum
+ "end" get save-xt
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } { f "s" } } }
+ { +output { "x" } }
+} define-intrinsic
+
+\ fixnum/mod [
+ finalize-contents
+ generate-fixnum/i
+ 0 "s" operand LI
+ "end" get B
+ "no-overflow" get save-xt
+ generate-fixnum-mod
+ "r" operand "x" operand tag-fixnum
+ "end" get save-xt
+] H{
+ { +input { { f "x" } { f "y" } } }
+ { +scratch { { f "r" } { f "s" } } }
+ { +output { "x" "s" } }
+} define-intrinsic
+
+: userenv ( reg -- )
+ #! Load the userenv pointer in a register.
+ "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
+
+\ getenv [
+ "n" operand dup 1 SRAWI
+ "x" operand userenv
+ "x" operand "n" operand "x" operand ADD
+ "x" operand dup 0 LWZ
+] H{
+ { +input { { f "n" } } }
+ { +scratch { { f "x" } } }
+ { +output { "x" } }
+ { +clobber { "n" } }
+} define-intrinsic
+
+\ setenv [
+ "n" operand dup 1 SRAWI
+ "x" operand userenv
+ "x" operand "n" operand "x" operand ADD
+ "val" operand "x" operand 0 STW
+] H{
+ { +input { { f "val" } { f "n" } } }
+ { +scratch { { f "x" } } }
+ { +clobber { "n" } }
+} define-intrinsic
projects / factor.git / commitdiff