159 lines
2.9 KiB
Factor
159 lines
2.9 KiB
Factor
|
! Copyright (C) 2005 Slava Pestov.
|
||
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
||
|
|
IN: compiler
|
||
|
|
USING: assembler generic hashtables inference kernel
|
||
|
|
kernel-internals lists math math-internals namespaces sequences
|
||
|
|
words ;
|
||
|
|
|
||
|
|
: immediate? ( obj -- ? )
|
||
|
|
#! fixnums and f have a pointerless representation, and
|
||
|
|
#! are compiled immediately. Everything else can be moved
|
||
|
|
#! by GC, and is indexed through a table.
|
||
|
|
dup fixnum? swap f eq? or ;
|
||
|
|
|
||
|
|
#push [
|
||
|
|
1 %inc-d ,
|
||
|
|
[ node-param get ] bind dup immediate? [
|
||
|
|
%immediate-d ,
|
||
|
|
] [
|
||
|
|
0 swap %indirect , out-1
|
||
|
|
] ifte
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ drop [
|
||
|
|
drop
|
||
|
|
1 %dec-d ,
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ dup [
|
||
|
|
drop
|
||
|
|
in-1
|
||
|
|
1 %inc-d ,
|
||
|
|
out-1
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ swap [
|
||
|
|
drop
|
||
|
|
in-2
|
||
|
|
1 0 %replace-d ,
|
||
|
|
0 1 %replace-d ,
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ over [
|
||
|
|
drop
|
||
|
|
0 1 %peek-d ,
|
||
|
|
1 %inc-d ,
|
||
|
|
out-1
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ pick [
|
||
|
|
drop
|
||
|
|
0 2 %peek-d ,
|
||
|
|
1 %inc-d ,
|
||
|
|
out-1
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
|
||
|
|
\ >r [
|
||
|
|
drop
|
||
|
|
in-1
|
||
|
|
1 %inc-r ,
|
||
|
|
1 %dec-d ,
|
||
|
|
0 0 %replace-r ,
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ r> [
|
||
|
|
drop
|
||
|
|
0 0 %peek-r ,
|
||
|
|
1 %inc-d ,
|
||
|
|
1 %dec-r ,
|
||
|
|
out-1
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
: top-literal? ( seq -- ? ) peek literal? ;
|
||
|
|
: peek-2 dup length 2 - swap nth ;
|
||
|
|
: next-typed? ( seq -- ? )
|
||
|
|
peek-2 value-types length 1 = ;
|
||
|
|
|
||
|
|
: self ( word -- )
|
||
|
|
f swap dup "infer-effect" word-prop (consume/produce) ;
|
||
|
|
|
||
|
|
\ slot [
|
||
|
|
\ slot self
|
||
|
|
] "infer" set-word-prop
|
||
|
|
|
||
|
|
: slot@ ( seq -- n )
|
||
|
|
#! Compute slot offset.
|
||
|
|
dup peek literal-value cell *
|
||
|
|
swap peek-2 value-types car type-tag - ;
|
||
|
|
|
||
|
|
\ slot [
|
||
|
|
node-consume-d swap hash
|
||
|
|
dup top-literal? over next-typed? and [
|
||
|
|
1 %dec-d ,
|
||
|
|
in-1
|
||
|
|
0 swap slot@ %fast-slot ,
|
||
|
|
] [
|
||
|
|
drop
|
||
|
|
in-2
|
||
|
|
1 %dec-d ,
|
||
|
|
1 %untag ,
|
||
|
|
1 0 %slot ,
|
||
|
|
] ifte out-1
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
\ set-slot [
|
||
|
|
\ set-slot self
|
||
|
|
] "infer" set-word-prop
|
||
|
|
|
||
|
|
\ set-slot [
|
||
|
|
node-consume-d swap hash
|
||
|
|
dup top-literal? over next-typed? and [
|
||
|
|
1 %dec-d ,
|
||
|
|
in-2
|
||
|
|
2 %dec-d ,
|
||
|
|
slot@ >r 1 0 r> %fast-set-slot ,
|
||
|
|
] [
|
||
|
|
drop
|
||
|
|
in-3
|
||
|
|
3 %dec-d ,
|
||
|
|
1 %untag ,
|
||
|
|
2 1 0 %set-slot ,
|
||
|
|
] ifte
|
||
|
|
] "linearizer" set-word-prop
|
||
|
|
|
||
|
|
! : binary-op-reg ( op -- )
|
||
|
|
! in-2
|
||
|
|
! [[ << vreg f 1 >> << vreg f 0 >> ]] cons ,
|
||
|
|
! 1 %dec-d , out-1 ;
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! : binary-op ( node op -- )
|
||
|
|
! top-literal? [
|
||
|
|
! 1 %dec-d ,
|
||
|
|
! in-1
|
||
|
|
! literal-value << vreg f 0 >> swons cons ,
|
||
|
|
! out-1
|
||
|
|
! ] [
|
||
|
|
! drop
|
||
|
|
! binary-op-reg
|
||
|
|
! ] ifte ;
|
||
|
|
!
|
||
|
|
! [
|
||
|
|
! fixnum+
|
||
|
|
! fixnum-
|
||
|
|
! fixnum*
|
||
|
|
! fixnum-mod
|
||
|
|
! fixnum-bitand
|
||
|
|
! fixnum-bitor
|
||
|
|
! fixnum-bitxor
|
||
|
|
! fixnum/i
|
||
|
|
! fixnum<=
|
||
|
|
! fixnum<
|
||
|
|
! fixnum>=
|
||
|
|
! fixnum>
|
||
|
|
! ] [
|
||
|
|
! dup [ literal, \ binary-op , ] make-list
|
||
|
|
! "linearizer" set-word-prop
|
||
|
|
! ] each
|