factor/library/compiler/intrinsics.factor

205 lines
5.2 KiB
Factor
Raw Normal View History

2006-04-01 19:50:33 -05:00
! 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 ;
2005-05-06 18:33:40 -04:00
2005-08-19 21:46:12 -04:00
: type-tag ( type -- tag )
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;
: value-tag ( value node -- n/f )
#! If the tag is known, output it, otherwise f.
2005-09-23 01:22:04 -04:00
node-classes ?hash dup [
2005-09-18 01:37:28 -04:00
types [ type-tag ] map dup all-equal?
2005-09-24 15:21:17 -04:00
[ first ] [ drop f ] if
] [
drop f
2005-09-24 15:21:17 -04:00
] if ;
2005-05-06 18:33:40 -04:00
: slot@ ( node -- n/f )
2005-05-06 18:33:40 -04:00
#! Compute slot offset.
dup node-in-d reverse-slice dup first dup value? [
value-literal cells swap second
2005-09-24 15:21:17 -04:00
rot value-tag dup [ - ] [ 2drop f ] if
] [
3drop f
2005-09-24 15:21:17 -04:00
] if ;
2005-05-09 22:34:47 -04:00
2005-05-06 18:33:40 -04:00
\ slot [
dup slot@ [
{ { 0 "obj" } { value "slot" } } { "obj" } [
node get slot@ "obj" get %fast-slot ,
] with-template
2005-05-06 18:33:40 -04:00
] [
{ { 0 "obj" } { 1 "n" } } { "obj" } [
"obj" get %untag ,
"n" get "obj" get %slot ,
] with-template
] if
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
\ set-slot [
dup slot@ [
{ { 0 "val" } { 1 "obj" } { value "slot" } } { } [
"val" get "obj" get node get slot@ %fast-set-slot ,
] with-template
] [
{ { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
"obj" get %untag ,
"val" get "obj" get "slot" get %set-slot ,
] with-template
2005-09-24 15:21:17 -04:00
] if
end-basic-block
2006-04-01 19:50:33 -05:00
T{ vreg f 1 } %write-barrier ,
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
2006-01-31 21:31:53 -05:00
\ char-slot [
{ { 0 "n" } { 1 "str" } } { "str" } [
"n" get "str" get %char-slot ,
] with-template
2006-01-31 21:31:53 -05:00
] "intrinsic" set-word-prop
\ set-char-slot [
{ { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
"ch" get "str" get "n" get %set-char-slot ,
] with-template
2006-01-31 21:31:53 -05:00
] "intrinsic" set-word-prop
\ type [
{ { 0 "in" } } { "in" }
[ end-basic-block "in" get %type , ] with-template
] "intrinsic" set-word-prop
\ tag [
{ { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
\ getenv [
{ { value "env" } } { "out" } [
T{ vreg f 0 } "out" set
"env" get "out" get %getenv ,
] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
\ setenv [
{ { 0 "value" } { value "env" } } { } [
"value" get "env" get %setenv ,
] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
: literal-immediate? ( node -- ? )
node-in-d peek dup value?
[ value-literal immediate? ] [ drop f ] if ;
: binary-in ( node -- in )
literal-immediate? fixnum-imm? and
{ { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
: (binary-op) ( node in -- )
{ "x" } [
end-basic-block >r "y" get "x" get dup r> execute ,
] with-template ; inline
2005-06-07 23:29:47 -04:00
: binary-op ( node op -- )
swap dup binary-in (binary-op) ; inline
2006-04-01 19:50:33 -05:00
: binary-op-reg ( node op -- )
swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
{
{ fixnum+ %fixnum+ }
{ fixnum- %fixnum- }
{ fixnum-bitand %fixnum-bitand }
{ fixnum-bitor %fixnum-bitor }
{ fixnum-bitxor %fixnum-bitxor }
} [
2005-10-01 01:44:49 -04:00
first2 [ binary-op ] curry "intrinsic" set-word-prop
] each
: binary-jump ( node label op -- )
rot dup binary-in { } [
end-basic-block >r >r "y" get "x" get r> r> execute ,
] with-template ; inline
2005-10-04 03:16:50 -04:00
{
{ fixnum<= %jump-fixnum<= }
{ fixnum< %jump-fixnum< }
{ fixnum>= %jump-fixnum>= }
{ fixnum> %jump-fixnum> }
{ eq? %jump-eq? }
} [
2005-10-01 01:44:49 -04:00
first2 [ binary-jump ] curry "if-intrinsic" set-word-prop
] each
\ fixnum/i [
\ %fixnum/i binary-op-reg
] "intrinsic" set-word-prop
\ 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.
{ { 0 "x" } { 1 "y" } } { "out" } [
end-basic-block
T{ vreg f 2 } "out" set
"y" get "x" get "out" get %fixnum-mod ,
] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
end-basic-block
T{ vreg f 0 } "quo" set
T{ vreg f 2 } "rem" set
"y" get "x" get 2array
"rem" get "quo" get 2array %fixnum/mod ,
] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
\ fixnum-bitnot [
{ { 0 "x" } } { "x" } [
"x" get dup %fixnum-bitnot ,
] with-template
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop
2005-05-09 22:34:47 -04:00
\ fixnum* [
\ %fixnum* binary-op-reg
] "intrinsic" set-word-prop
2005-05-09 22:34:47 -04:00
: slow-shift ( -- ) \ fixnum-shift %call , ;
: negative-shift ( n node -- )
{ { 0 "x" } { value "n" } } { "out" } [
dup cell-bits neg <= [
drop
T{ vreg f 2 } "out" set
"x" get "out" get %fixnum-sgn ,
] [
"x" get "out" set
neg "x" get "out" get %fixnum>> ,
] if
] with-template ;
2005-05-09 22:34:47 -04:00
: fast-shift ( n node -- )
over zero? [
end-basic-block -1 0 adjust-stacks 2drop
2005-05-09 22:34:47 -04:00
] [
over 0 < [
2005-05-09 22:34:47 -04:00
negative-shift
] [
2drop slow-shift
2005-09-24 15:21:17 -04:00
] if
] if ;
2005-05-09 22:34:47 -04:00
\ fixnum-shift [
end-basic-block
dup literal-immediate? [
[ node-in-d peek value-literal ] keep fast-shift
2005-05-09 22:34:47 -04:00
] [
drop slow-shift
2005-09-24 15:21:17 -04:00
] if
2005-05-17 16:13:08 -04:00
] "intrinsic" set-word-prop