2006-04-01 19:50:33 -05:00
|
|
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2005-05-09 02:34:15 -04:00
|
|
|
IN: compiler-frontend
|
2005-09-11 20:46:55 -04:00
|
|
|
USING: arrays assembler compiler-backend 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 ;
|
|
|
|
|
2005-08-15 23:09:44 -04:00
|
|
|
: 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
|
2005-08-15 23:09:44 -04:00
|
|
|
] [
|
|
|
|
drop f
|
2005-09-24 15:21:17 -04:00
|
|
|
] if ;
|
2005-05-06 18:33:40 -04:00
|
|
|
|
2005-08-15 23:09:44 -04:00
|
|
|
: slot@ ( node -- n/f )
|
2005-05-06 18:33:40 -04:00
|
|
|
#! Compute slot offset.
|
2006-01-22 16:40:18 -05:00
|
|
|
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
|
2005-08-15 23:09:44 -04:00
|
|
|
] [
|
|
|
|
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 [
|
2005-08-15 23:09:44 -04:00
|
|
|
dup slot@ [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "obj" } { f "slot" } } { "obj" } [
|
|
|
|
node get slot@ "obj" get %fast-slot ,
|
|
|
|
] with-template
|
2005-05-06 18:33:40 -04:00
|
|
|
] [
|
2006-04-01 23:42:36 -05: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
|
2005-05-13 20:37:28 -04:00
|
|
|
|
|
|
|
\ set-slot [
|
2005-08-15 23:09:44 -04:00
|
|
|
dup slot@ [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "val" } { 1 "obj" } { f "slot" } } { } [
|
|
|
|
"val" get "obj" get node get slot@ %fast-set-slot ,
|
|
|
|
] with-template
|
2005-05-13 20:37:28 -04:00
|
|
|
] [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 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
|
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
|
2005-05-06 19:49:07 -04:00
|
|
|
|
2006-01-31 21:31:53 -05:00
|
|
|
\ char-slot [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 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 [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 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
|
2005-11-13 22:04:14 -05:00
|
|
|
|
2005-05-06 19:49:07 -04:00
|
|
|
\ type [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "in" } } { "in" } [ "in" get %type , ] with-template
|
2005-08-15 15:34:00 -04:00
|
|
|
] "intrinsic" set-word-prop
|
|
|
|
|
|
|
|
\ tag [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
|
2005-05-17 16:13:08 -04:00
|
|
|
] "intrinsic" set-word-prop
|
2005-05-07 22:39:00 -04:00
|
|
|
|
2005-05-13 20:37:28 -04:00
|
|
|
\ getenv [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { f "env" } } { "out" } [
|
|
|
|
T{ vreg f 0 } "out" set
|
2006-04-03 01:33:52 -04:00
|
|
|
"env" get "out" get %getenv ,
|
2006-04-01 23:42:36 -05:00
|
|
|
] with-template
|
2005-05-17 16:13:08 -04:00
|
|
|
] "intrinsic" set-word-prop
|
2005-05-13 20:37:28 -04:00
|
|
|
|
|
|
|
\ setenv [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "value" } { f "env" } } { } [
|
2006-04-03 01:33:52 -04:00
|
|
|
"value" get "env" get %setenv ,
|
2006-04-01 23:42:36 -05:00
|
|
|
] with-template
|
2005-05-17 16:13:08 -04:00
|
|
|
] "intrinsic" set-word-prop
|
2005-05-13 20:37:28 -04:00
|
|
|
|
2006-04-01 23:42:36 -05:00
|
|
|
: literal-immediate? ( node -- ? )
|
|
|
|
node-in-d peek dup value?
|
|
|
|
[ value-literal immediate? ] [ drop f ] if ;
|
2005-09-09 22:34:24 -04:00
|
|
|
|
2006-04-01 23:42:36 -05:00
|
|
|
: binary-in ( node -- in )
|
|
|
|
literal-immediate? fixnum-imm? and
|
|
|
|
{ { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
|
2005-09-09 22:34:24 -04:00
|
|
|
|
2006-04-01 23:42:36 -05:00
|
|
|
: (binary-op) ( node in -- )
|
|
|
|
{ "x" } [
|
|
|
|
>r "y" get "x" get dup r> execute ,
|
|
|
|
] with-template ; inline
|
2005-06-07 23:29:47 -04:00
|
|
|
|
|
|
|
: binary-op ( node op -- )
|
2006-04-01 23:42:36 -05:00
|
|
|
swap dup binary-in (binary-op) ; inline
|
2006-04-01 19:50:33 -05:00
|
|
|
|
|
|
|
: binary-op-reg ( node op -- )
|
2006-04-01 23:42:36 -05:00
|
|
|
swap { { 0 "x" } { 1 "y" } } (binary-op) ; inline
|
2005-05-06 19:49:07 -04:00
|
|
|
|
2005-10-29 23:25:38 -04:00
|
|
|
{
|
|
|
|
{ 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
|
2005-05-06 19:49:07 -04:00
|
|
|
] each
|
2005-05-07 22:39:00 -04:00
|
|
|
|
2005-09-09 22:34:24 -04:00
|
|
|
: binary-jump ( node label op -- )
|
2006-04-01 23:42:36 -05:00
|
|
|
rot dup binary-in { } [
|
|
|
|
>r >r "y" get "x" get r> r> execute ,
|
|
|
|
] with-template ; inline
|
2005-10-04 03:16:50 -04:00
|
|
|
|
2005-10-29 23:25:38 -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
|
2005-09-09 18:00:38 -04:00
|
|
|
] each
|
|
|
|
|
2005-09-09 22:34:24 -04:00
|
|
|
\ fixnum/i [
|
|
|
|
\ %fixnum/i binary-op-reg
|
|
|
|
] "intrinsic" set-word-prop
|
|
|
|
|
2005-05-07 22:39:00 -04:00
|
|
|
\ 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.
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "x" } { 1 "y" } } { "out" } [
|
|
|
|
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
|
2005-05-07 22:39:00 -04:00
|
|
|
|
|
|
|
\ fixnum/mod [
|
|
|
|
! See the remark on fixnum-mod for vreg usage
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
|
|
|
|
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
|
2005-05-07 22:39:00 -04:00
|
|
|
|
|
|
|
\ fixnum-bitnot [
|
2006-04-01 23:42:36 -05:00
|
|
|
{ { 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
|
|
|
|
2005-09-09 22:34:24 -04:00
|
|
|
\ fixnum* [
|
2006-01-22 16:40:18 -05:00
|
|
|
\ %fixnum* binary-op-reg
|
2005-09-09 22:34:24 -04:00
|
|
|
] "intrinsic" set-word-prop
|
|
|
|
|
2005-05-09 22:34:47 -04:00
|
|
|
: slow-shift ( -- ) \ fixnum-shift %call , ;
|
|
|
|
|
2006-04-01 23:42:36 -05:00
|
|
|
: negative-shift ( n node -- )
|
|
|
|
{ { 0 "x" } { f "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
|
|
|
|
2006-04-01 23:42:36 -05:00
|
|
|
: fast-shift ( n node -- )
|
|
|
|
over zero? [
|
|
|
|
-1 %inc-d , 2drop
|
2005-05-09 22:34:47 -04:00
|
|
|
] [
|
2006-04-01 23:42:36 -05:00
|
|
|
over 0 < [
|
2005-05-09 22:34:47 -04:00
|
|
|
negative-shift
|
|
|
|
] [
|
2006-04-01 23:42:36 -05:00
|
|
|
2drop slow-shift
|
2005-09-24 15:21:17 -04:00
|
|
|
] if
|
|
|
|
] if ;
|
2005-05-09 22:34:47 -04:00
|
|
|
|
|
|
|
\ fixnum-shift [
|
2006-04-01 23:42:36 -05:00
|
|
|
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
|