VOPs
Slava Pestov
parent
958f20e97c
commit
429eb9cdb5
|
|
@ -5,21 +5,10 @@ IN: assembler
|
|||
DEFER: compile-call-label ( label -- )
|
||||
DEFER: compile-jump-label ( label -- )
|
||||
|
||||
DEFER: compile-jump-t ( label -- )
|
||||
DEFER: compile-jump-f ( label -- )
|
||||
|
||||
IN: compiler
|
||||
USING: assembler errors inference kernel lists math namespaces
|
||||
sequences strings vectors words ;
|
||||
|
||||
: generate-node ( [[ op params ]] -- )
|
||||
#! Generate machine code for a node.
|
||||
unswons dup "generator" word-prop [
|
||||
call
|
||||
] [
|
||||
"No generator" throw
|
||||
] ?ifte ;
|
||||
|
||||
: generate-code ( word linear -- length )
|
||||
compiled-offset >r
|
||||
compile-aligned
|
||||
|
|
@ -56,38 +45,22 @@ SYMBOL: previous-offset
|
|||
] when*
|
||||
] catch ;
|
||||
|
||||
#label [ save-xt ] "generator" set-word-prop
|
||||
! A few VOPs have trivial generators.
|
||||
|
||||
#end-dispatch [ drop ] "generator" set-word-prop
|
||||
M: %label generate-node ( vop -- )
|
||||
vop-label save-xt ;
|
||||
|
||||
: type-tag ( type -- tag )
|
||||
#! Given a type number, return the tag number.
|
||||
dup 6 > [ drop 3 ] when ;
|
||||
M: %end-dispatch generate-node ( vop -- ) drop ;
|
||||
|
||||
: compile-call ( word -- ) dup postpone-word compile-call-label ;
|
||||
|
||||
#call [
|
||||
compile-call
|
||||
] "generator" set-word-prop
|
||||
M: %call generate-node vop-label compile-call ;
|
||||
|
||||
#jump-label [
|
||||
compile-jump-label
|
||||
] "generator" set-word-prop
|
||||
|
||||
#jump-t-label [ compile-jump-t ] "generator" set-word-prop
|
||||
#jump-t [ compile-jump-t ] "generator" set-word-prop
|
||||
|
||||
#jump-f-label [ compile-jump-f ] "generator" set-word-prop
|
||||
#jump-f [ compile-jump-f ] "generator" set-word-prop
|
||||
M: %jump-label generate-node vop-label compile-jump-label ;
|
||||
|
||||
: compile-target ( word -- ) 0 compile-cell absolute ;
|
||||
|
||||
#target-label [
|
||||
#! Jump table entries are absolute addresses.
|
||||
compile-target
|
||||
] "generator" set-word-prop
|
||||
M: %target-label generate-node vop-label compile-target ;
|
||||
|
||||
#target [
|
||||
#! Jump table entries are absolute addresses.
|
||||
dup postpone-word compile-target
|
||||
] "generator" set-word-prop
|
||||
M: %target generate-node
|
||||
vop-label dup postpone-word compile-target ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,158 @@
|
|||
! 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
|
||||
|
|
@ -4,47 +4,11 @@ IN: compiler
|
|||
USING: inference kernel lists math namespaces words strings
|
||||
errors prettyprint kernel-internals ;
|
||||
|
||||
! The linear IR is close to assembly language. It also resembles
|
||||
! Forth code in some sense. It exists so that pattern matching
|
||||
! optimization can be performed against it.
|
||||
|
||||
! Linear IR nodes. This is in addition to the symbols already
|
||||
! defined in inference vocab.
|
||||
|
||||
SYMBOL: #push-immediate
|
||||
SYMBOL: #push-indirect
|
||||
SYMBOL: #replace-immediate
|
||||
SYMBOL: #replace-indirect
|
||||
SYMBOL: #jump-t ( branch if top of stack is true )
|
||||
SYMBOL: #jump-t-label ( branch if top of stack is true )
|
||||
SYMBOL: #jump-f ( branch if top of stack is false )
|
||||
SYMBOL: #jump-f-label ( branch if top of stack is false )
|
||||
SYMBOL: #jump ( tail-call )
|
||||
SYMBOL: #jump-label ( tail-call )
|
||||
SYMBOL: #return-to ( push addr on C stack )
|
||||
|
||||
! dispatch is linearized as dispatch followed by a #target or
|
||||
! #target-label for each dispatch table entry. The dispatch
|
||||
! table terminates with #end-dispatch. The linearizer ensures
|
||||
! the correct number of #targets is emitted.
|
||||
SYMBOL: #target ( part of jump table )
|
||||
SYMBOL: #target-label
|
||||
SYMBOL: #end-dispatch
|
||||
|
||||
! on PowerPC, compiled definitions that make subroutine calls
|
||||
! must have a prologue and epilogue to set up and tear down the
|
||||
! link register. The epilogue is compiled as part of #return.
|
||||
SYMBOL: #prologue
|
||||
|
||||
: linear, ( node -- )
|
||||
#! Add a node to the linear IR.
|
||||
[ node-op get node-param get ] bind cons , ;
|
||||
|
||||
: >linear ( node -- )
|
||||
#! Dataflow OPs have a linearizer word property. This
|
||||
#! quotation is executed to convert the node into linear
|
||||
#! form.
|
||||
"linearizer" [ linear, ] apply-dataflow ;
|
||||
"linearizer" [ "No linearizer" throw ] apply-dataflow ;
|
||||
|
||||
: (linearize) ( dataflow -- )
|
||||
[ >linear ] each ;
|
||||
|
|
@ -55,19 +19,7 @@ SYMBOL: #prologue
|
|||
#! jumps and labels, and turns dataflow IR nodes into
|
||||
#! lists where the first element is an operation, and the
|
||||
#! rest is arguments.
|
||||
[ [ #prologue ] , (linearize) ] make-list ;
|
||||
|
||||
: 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 [
|
||||
[ node-param get ] bind
|
||||
dup immediate? #push-immediate #push-indirect ?
|
||||
swons ,
|
||||
] "linearizer" set-word-prop
|
||||
[ %prologue , (linearize) ] make-list ;
|
||||
|
||||
: <label> ( -- label )
|
||||
gensym dup t "label" set-word-prop ;
|
||||
|
|
@ -75,13 +27,10 @@ SYMBOL: #prologue
|
|||
: label? ( obj -- ? )
|
||||
dup word? [ "label" word-prop ] [ drop f ] ifte ;
|
||||
|
||||
: label, ( label -- )
|
||||
#label swons , ;
|
||||
|
||||
: linearize-simple-label ( node -- )
|
||||
#! Some labels become simple labels after the optimization
|
||||
#! stage.
|
||||
dup [ node-label get ] bind label,
|
||||
dup [ node-label get ] bind %label ,
|
||||
[ node-param get ] bind (linearize) ;
|
||||
|
||||
#simple-label [
|
||||
|
|
@ -91,29 +40,36 @@ SYMBOL: #prologue
|
|||
: linearize-label ( node -- )
|
||||
#! Labels are tricky, because they might contain non-tail
|
||||
#! calls. So we push the address of the location right after
|
||||
#! the label, then linearize the label, then add a #return
|
||||
#! the #label , then linearize the #label , then add a #return
|
||||
#! node to the linear IR. The simplifier will take care of
|
||||
#! this in the common case where the labelled block does
|
||||
#! not contain non-tail recursive calls to itself.
|
||||
<label> dup #return-to swons , >r
|
||||
<label> dup %return-to , >r
|
||||
linearize-simple-label
|
||||
[ #return ] ,
|
||||
r> label, ;
|
||||
%return ,
|
||||
r> %label , ;
|
||||
|
||||
#label [
|
||||
linearize-label
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
#call [
|
||||
[ node-param get ] bind %call ,
|
||||
] "linearizer" set-word-prop
|
||||
|
||||
: conditional ( label -- )
|
||||
in-1 1 %dec-d , 0 %jump-t , ;
|
||||
|
||||
: linearize-ifte ( param -- )
|
||||
#! The parameter is a list of two lists, each one a dataflow
|
||||
#! IR.
|
||||
2unlist <label> [
|
||||
#jump-t-label swons ,
|
||||
conditional
|
||||
(linearize) ( false branch )
|
||||
<label> dup #jump-label swons ,
|
||||
] keep label, ( branch target of BRANCH-T )
|
||||
<label> dup %jump-label ,
|
||||
] keep %label , ( branch target of BRANCH-T )
|
||||
swap (linearize) ( true branch )
|
||||
label, ( branch target of false branch end ) ;
|
||||
%label , ( branch target of false branch end ) ;
|
||||
|
||||
\ ifte [
|
||||
[ node-param get ] bind linearize-ifte
|
||||
|
|
@ -122,19 +78,19 @@ SYMBOL: #prologue
|
|||
: dispatch-head ( vtable -- end label/code )
|
||||
#! Output the jump table insn and return a list of
|
||||
#! label/branch pairs.
|
||||
[ dispatch ] ,
|
||||
%dispatch ,
|
||||
<label> ( end label ) swap
|
||||
[ <label> dup #target-label swons , cons ] map
|
||||
[ #end-dispatch ] , ;
|
||||
[ <label> dup %target-label , cons ] map
|
||||
%end-dispatch , ;
|
||||
|
||||
: dispatch-body ( end label/param -- )
|
||||
#! Output each branch, with a jump to the end label.
|
||||
[ uncons label, (linearize) #jump-label swons , ] each-with ;
|
||||
[ uncons %label , (linearize) %jump-label , ] each-with ;
|
||||
|
||||
: linearize-dispatch ( vtable -- )
|
||||
#! The parameter is a list of lists, each one is a branch to
|
||||
#! take in case the top of stack has that type.
|
||||
dispatch-head dupd dispatch-body label, ;
|
||||
dispatch-head dupd dispatch-body %label , ;
|
||||
|
||||
\ dispatch [
|
||||
[ node-param get ] bind linearize-dispatch
|
||||
|
|
@ -142,4 +98,4 @@ SYMBOL: #prologue
|
|||
|
||||
#values [ drop ] "linearizer" set-word-prop
|
||||
|
||||
#return [ drop [ #return ] , ] "linearizer" set-word-prop
|
||||
#return [ drop %return , ] "linearizer" set-word-prop
|
||||
|
|
|
|||
|
|
@ -56,11 +56,6 @@ SYMBOL: simplifying
|
|||
#! its param.
|
||||
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
|
||||
|
||||
\ >r [ [ \ r> cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ r> [ [ \ >r cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ dup [ [ \ drop cancel nip ] ] "simplifiers" set-word-prop
|
||||
\ swap [ [ \ swap cancel nip ] ] "simplifiers" set-word-prop
|
||||
|
||||
\ drop [
|
||||
[
|
||||
#push-immediate cancel [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler
|
||||
USING: generic kernel namespaces parser ;
|
||||
|
||||
! The linear IR is the second of the two intermediate
|
||||
! representations used by Factor. It is basically a high-level
|
||||
! assembly language. Linear IR operations are called VOPs.
|
||||
|
||||
! A virtual register
|
||||
TUPLE: vreg n ;
|
||||
|
||||
! A virtual operation
|
||||
TUPLE: vop source dest literal label ;
|
||||
|
||||
! Compile a VOP.
|
||||
GENERIC: generate-node ( vop -- )
|
||||
|
||||
: make-vop ( source dest literal label vop -- vop )
|
||||
[ >r <vop> r> set-delegate ] keep ;
|
||||
|
||||
: VOP:
|
||||
#! Followed by a VOP name.
|
||||
scan dup [ ] define-tuple
|
||||
create-in [ make-vop ] define-constructor ; parsing
|
||||
|
||||
: empty-vop f f f f ;
|
||||
: label-vop ( label) >r f f f r> ;
|
||||
: label/src-vop ( label src) swap >r f f r> ;
|
||||
: src-vop ( src) f f f ;
|
||||
|
||||
! miscellanea
|
||||
VOP: %prologue
|
||||
: %prologue empty-vop <%prologue> ;
|
||||
VOP: %label
|
||||
: %label label-vop <%label> ;
|
||||
VOP: %return
|
||||
: %return empty-vop <%return> ;
|
||||
VOP: %return-to
|
||||
: %return-to label-vop <%return-to> ;
|
||||
VOP: %jump
|
||||
: %jump label-vop <%jump> ;
|
||||
VOP: %jump-label
|
||||
: %jump-label label-vop <%jump-label> ;
|
||||
VOP: %call
|
||||
: %call label-vop <%call> ;
|
||||
VOP: %call-label
|
||||
: %call-label label-vop <%call-label> ;
|
||||
VOP: %jump-t
|
||||
: %jump-t <vreg> label/src-vop <%jump-t> ;
|
||||
VOP: %jump-f
|
||||
: %jump-f <vreg> label/src-vop <%jump-f> ;
|
||||
|
||||
! dispatch tables
|
||||
VOP: %dispatch
|
||||
: %dispatch empty-vop <%dispatch> ;
|
||||
VOP: %target-label
|
||||
: %target-label label-vop <%target-label> ;
|
||||
VOP: %target
|
||||
: %target label-vop <%target> ;
|
||||
VOP: %end-dispatch
|
||||
: %end-dispatch empty-vop <%end-dispatch> ;
|
||||
|
||||
! stack operations
|
||||
VOP: %peek-d
|
||||
: %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
|
||||
VOP: %dec-d
|
||||
: %dec-d ( n -- ) >r f f r> f <%dec-d> ;
|
||||
VOP: %replace-d
|
||||
: %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
|
||||
VOP: %inc-d
|
||||
: %inc-d ( n -- ) >r f f r> f <%inc-d> ;
|
||||
VOP: %immediate
|
||||
VOP: %immediate-d
|
||||
: %immediate-d ( obj -- ) >r f f r> f <%immediate-d> ;
|
||||
VOP: %peek-r
|
||||
: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
|
||||
VOP: %dec-r
|
||||
: %dec-r ( n -- ) >r f f r> f <%dec-r> ;
|
||||
VOP: %replace-r
|
||||
: %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
|
||||
VOP: %inc-r
|
||||
: %inc-r ( n -- ) >r f f r> f <%inc-r> ;
|
||||
|
||||
: in-1 0 0 %peek-d , ;
|
||||
: in-2 in-1 1 1 %peek-d , ;
|
||||
: in-3 in-2 2 2 %peek-d , ;
|
||||
: out-1 0 0 %replace-d , ;
|
||||
: out-2 out-1 1 1 %replace-d , ;
|
||||
|
||||
! indirect load of a literal through a table
|
||||
VOP: %indirect
|
||||
: %indirect ( vreg obj -- ) f -rot f <%indirect> ;
|
||||
|
||||
! object slot accessors
|
||||
VOP: %untag
|
||||
: %untag <vreg> src-vop <%untag> ;
|
||||
VOP: %slot
|
||||
: %slot ( vreg n ) >r >r f r> <vreg> r> <vreg> f <%slot> ;
|
||||
|
||||
VOP: %set-slot
|
||||
: %set-slot ( vreg:value vreg:obj n )
|
||||
>r >r <vreg> r> <vreg> r> <vreg> f <%set-slot> ;
|
||||
|
||||
! In the 'fast' versions, the object's type and slot number is
|
||||
! known at compile time, so these become a single instruction
|
||||
VOP: %fast-slot
|
||||
: %fast-slot ( vreg n ) >r >r f r> <vreg> r> f <%fast-slot> ;
|
||||
VOP: %fast-set-slot
|
||||
: %fast-set-slot ( vreg:value vreg:obj n )
|
||||
>r >r <vreg> r> <vreg> r> f <%fast-set-slot> ;
|
||||
|
|
@ -42,9 +42,6 @@ USE: math-internals
|
|||
! values happends. At this point in time, this is just a
|
||||
! prototype to test the assembler.
|
||||
|
||||
: self ( word -- )
|
||||
f swap dup "infer-effect" word-prop (consume/produce) ;
|
||||
|
||||
: fixnum-insn ( overflow opcode -- )
|
||||
#! This needs to be factored.
|
||||
EAX [ ESI -4 ] MOV
|
||||
|
|
@ -136,6 +133,11 @@ USE: math-internals
|
|||
|
||||
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop
|
||||
|
||||
: PUSH-DS ( -- )
|
||||
#! Push EAX to datastack.
|
||||
ESI 4 ADD
|
||||
[ ESI ] EAX MOV ;
|
||||
|
||||
\ arithmetic-type [
|
||||
drop
|
||||
EAX [ ESI -4 ] MOV
|
||||
|
|
|
|||
|
|
@ -2,45 +2,77 @@
|
|||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: assembler
|
||||
USING: alien compiler inference kernel kernel-internals lists
|
||||
math memory namespaces words ;
|
||||
math memory namespaces sequences words ;
|
||||
|
||||
GENERIC: v>operand
|
||||
M: integer v>operand ;
|
||||
M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
|
||||
|
||||
! Not used on x86
|
||||
#prologue [ drop ] "generator" set-word-prop
|
||||
|
||||
\ slot [
|
||||
PEEK-DS
|
||||
2unlist type-tag >r cell * r> - EAX swap 2list EAX swap MOV
|
||||
[ ESI ] EAX MOV
|
||||
] "generator" set-word-prop
|
||||
M: %prologue generate-node drop ;
|
||||
|
||||
: compile-call-label ( label -- ) 0 CALL relative ;
|
||||
: compile-jump-label ( label -- ) 0 JMP relative ;
|
||||
|
||||
#call-label [
|
||||
compile-call-label
|
||||
] "generator" set-word-prop
|
||||
M: %call-label generate-node ( vop -- )
|
||||
vop-label compile-call-label ;
|
||||
|
||||
#jump [
|
||||
dup postpone-word compile-jump-label
|
||||
] "generator" set-word-prop
|
||||
M: %jump generate-node ( vop -- )
|
||||
vop-label dup postpone-word compile-jump-label ;
|
||||
|
||||
: compile-jump-t ( word -- )
|
||||
POP-DS
|
||||
! condition is now in EAX
|
||||
EAX f address CMP
|
||||
! jump w/ address added later
|
||||
0 JNE relative ;
|
||||
M: %jump-f generate-node ( vop -- )
|
||||
dup vop-source v>operand f address CMP 0 JNE
|
||||
vop-label relative ;
|
||||
|
||||
: compile-jump-f ( word -- )
|
||||
POP-DS
|
||||
! condition is now in EAX
|
||||
EAX f address CMP
|
||||
! jump w/ address added later
|
||||
0 JE relative ;
|
||||
M: %jump-t generate-node ( vop -- )
|
||||
dup vop-source v>operand f address CMP 0 JE
|
||||
vop-label relative ;
|
||||
|
||||
#return-to [ 0 PUSH absolute ] "generator" set-word-prop
|
||||
M: %return-to generate-node ( vop -- )
|
||||
0 PUSH vop-label absolute ;
|
||||
|
||||
#return [ drop RET ] "generator" set-word-prop
|
||||
M: %return generate-node ( vop -- )
|
||||
drop RET ;
|
||||
|
||||
M: %untag generate-node ( vop -- )
|
||||
vop-source v>operand BIN: 111 bitnot AND ;
|
||||
|
||||
M: %slot generate-node ( vop -- )
|
||||
! the untagged object is in vop-dest, the tagged slot number
|
||||
! is in vop-literal.
|
||||
dup vop-literal v>operand swap vop-dest v>operand
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
over 1 SHR
|
||||
! compute slot address in vop-dest
|
||||
dupd ADD
|
||||
! load slot value in vop-dest
|
||||
dup unit MOV ;
|
||||
|
||||
M: %fast-slot generate-node ( vop -- )
|
||||
! the tagged object is in vop-dest, the pointer offset is
|
||||
! in vop-literal. the offset already takes the type tag
|
||||
! into account, so its just one instruction to load.
|
||||
dup vop-literal swap vop-dest v>operand tuck >r 2list r>
|
||||
swap MOV ;
|
||||
|
||||
M: %set-slot generate-node ( vop -- )
|
||||
! the untagged object is in vop-dest, the new value is in
|
||||
! vop-source, the tagged slot number is in vop-literal.
|
||||
dup vop-literal v>operand over vop-dest v>operand
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
over 1 SHR
|
||||
! compute slot address in vop-dest
|
||||
dupd ADD
|
||||
! store new slot value
|
||||
>r vop-source v>operand r> unit swap MOV ;
|
||||
|
||||
M: %fast-set-slot generate-node ( vop -- )
|
||||
! the tagged object is in vop-dest, the new value is in
|
||||
! vop-source, the pointer offset is in vop-literal. the
|
||||
! offset already takes the type tag into account, so its
|
||||
! just one instruction to load.
|
||||
dup vop-literal over vop-dest v>operand swap 2list
|
||||
swap vop-source v>operand MOV ;
|
||||
|
||||
\ dispatch [
|
||||
#! Compile a piece of code that jumps to an offset in a
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! See http://factor.sf.net/license.txt for BSD license.
|
||||
IN: compiler
|
||||
USING: inference kernel assembler words lists alien memory ;
|
||||
USING: alien assembler inference kernel lists math memory
|
||||
sequences words ;
|
||||
|
||||
: rel-cs ( -- )
|
||||
#! Add an entry to the relocation table for the 32-bit
|
||||
|
|
@ -12,102 +13,47 @@ USING: inference kernel assembler words lists alien memory ;
|
|||
: CS> ( register -- ) CS MOV rel-cs ;
|
||||
: >CS ( register -- ) CS swap MOV rel-cs ;
|
||||
|
||||
: PEEK-DS ( -- )
|
||||
#! Peek datastack to EAX.
|
||||
EAX [ ESI ] MOV ;
|
||||
: reg-stack ( reg n -- op ) cell * neg 2list ;
|
||||
: ds-op ( n -- op ) ESI swap reg-stack ;
|
||||
: rs-op ( n -- op ) ECX swap reg-stack ;
|
||||
|
||||
: POP-DS ( -- )
|
||||
#! Pop datastack to EAX.
|
||||
PEEK-DS
|
||||
ESI 4 SUB ;
|
||||
M: %peek-d generate-node ( vop -- )
|
||||
dup vop-dest v>operand swap vop-literal ds-op MOV ;
|
||||
|
||||
: PUSH-DS ( -- )
|
||||
#! Push EAX to datastack.
|
||||
ESI 4 ADD
|
||||
[ ESI ] EAX MOV ;
|
||||
M: %dec-d generate-node ( vop -- )
|
||||
vop-literal ESI swap cell * SUB ;
|
||||
|
||||
: PEEK-CS ( -- )
|
||||
#! Peek return stack to EAX.
|
||||
ECX CS>
|
||||
EAX [ ECX ] MOV ;
|
||||
M: %replace-d generate-node ( vop -- )
|
||||
dup vop-source v>operand swap vop-literal ds-op swap MOV ;
|
||||
|
||||
: POP-CS ( -- )
|
||||
#! Pop return stack to EAX.
|
||||
PEEK-CS
|
||||
ECX 4 SUB
|
||||
M: %inc-d generate-node ( vop -- )
|
||||
vop-literal ESI swap cell * ADD ;
|
||||
|
||||
M: %immediate generate-node ( vop -- )
|
||||
dup vop-dest v>operand swap vop-literal address MOV ;
|
||||
|
||||
M: %immediate-d generate-node ( vop -- )
|
||||
vop-literal [ ESI ] swap address MOV ;
|
||||
|
||||
M: %indirect generate-node ( vop -- )
|
||||
#! indirect load of a literal through a table
|
||||
dup vop-dest v>operand
|
||||
swap vop-literal intern-literal unit MOV
|
||||
f rel-address ;
|
||||
|
||||
M: %peek-r generate-node ( vop -- )
|
||||
ECX CS> dup vop-dest v>operand swap vop-literal rs-op MOV ;
|
||||
|
||||
M: %dec-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
vop-literal ECX swap cell * SUB ECX >CS ;
|
||||
|
||||
M: %replace-r generate-node ( vop -- )
|
||||
#! Can only follow a %inc-r
|
||||
dup vop-source v>operand swap vop-literal rs-op swap MOV
|
||||
ECX >CS ;
|
||||
|
||||
: PUSH-CS ( -- )
|
||||
#! Push EAX to return stack.
|
||||
ECX 4 ADD
|
||||
[ ECX ] EAX MOV
|
||||
ECX >CS ;
|
||||
|
||||
: immediate-literal ( obj -- )
|
||||
[ ESI ] swap address MOV ;
|
||||
|
||||
: indirect-literal ( obj -- )
|
||||
EAX swap intern-literal unit MOV f rel-address ;
|
||||
|
||||
#push-immediate [
|
||||
ESI 4 ADD
|
||||
immediate-literal
|
||||
] "generator" set-word-prop
|
||||
|
||||
#push-indirect [
|
||||
indirect-literal
|
||||
PUSH-DS
|
||||
] "generator" set-word-prop
|
||||
|
||||
#replace-immediate [
|
||||
immediate-literal
|
||||
] "generator" set-word-prop
|
||||
|
||||
#replace-indirect [
|
||||
indirect-literal
|
||||
[ ESI ] EAX MOV
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ drop [
|
||||
drop
|
||||
ESI 4 SUB
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ dup [
|
||||
drop
|
||||
PEEK-DS
|
||||
PUSH-DS
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ swap [
|
||||
drop
|
||||
EAX [ ESI ] MOV
|
||||
EDX [ ESI -4 ] MOV
|
||||
[ ESI ] EDX MOV
|
||||
[ ESI -4 ] EAX MOV
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ over [
|
||||
drop
|
||||
EAX [ ESI -4 ] MOV
|
||||
PUSH-DS
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ pick [
|
||||
drop
|
||||
EAX [ ESI -8 ] MOV
|
||||
PUSH-DS
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ >r [
|
||||
drop
|
||||
POP-DS
|
||||
M: %inc-r generate-node ( vop -- )
|
||||
#! Can only follow a %peek-r
|
||||
ECX CS>
|
||||
PUSH-CS
|
||||
] "generator" set-word-prop
|
||||
|
||||
\ r> [
|
||||
drop
|
||||
POP-CS
|
||||
PUSH-DS
|
||||
] "generator" set-word-prop
|
||||
vop-literal ECX swap cell * ADD ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue