steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

VOPs

cvs
Slava Pestov 2005-05-06 22:33:40 +00:00
parent 958f20e97c
commit 429eb9cdb5
8 changed files with 406 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
library/compiler/generator.factor
View File

@ -5,21 +5,10 @@ IN: assembler
DEFER: compile-call-label ( label -- ) DEFER: compile-call-label ( label -- )
DEFER: compile-jump-label ( label -- ) DEFER: compile-jump-label ( label -- )
DEFER: compile-jump-t ( label -- )
DEFER: compile-jump-f ( label -- )
IN: compiler IN: compiler
USING: assembler errors inference kernel lists math namespaces USING: assembler errors inference kernel lists math namespaces
sequences strings vectors words ; 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 ) : generate-code ( word linear -- length )
compiled-offset >r compiled-offset >r
compile-aligned compile-aligned
@ -56,38 +45,22 @@ SYMBOL: previous-offset
] when* ] when*
] catch ; ] 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 ) M: %end-dispatch generate-node ( vop -- ) drop ;
#! Given a type number, return the tag number.
dup 6 > [ drop 3 ] when ;
: compile-call ( word -- ) dup postpone-word compile-call-label ; : compile-call ( word -- ) dup postpone-word compile-call-label ;
#call [ M: %call generate-node vop-label compile-call ;
compile-call
] "generator" set-word-prop
#jump-label [ M: %jump-label generate-node vop-label compile-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
: compile-target ( word -- ) 0 compile-cell absolute ; : compile-target ( word -- ) 0 compile-cell absolute ;
#target-label [ M: %target-label generate-node vop-label compile-target ;
#! Jump table entries are absolute addresses.
compile-target
] "generator" set-word-prop
#target [ M: %target generate-node
#! Jump table entries are absolute addresses. vop-label dup postpone-word compile-target ;
dup postpone-word compile-target
] "generator" set-word-prop

158
library/compiler/intrinsics.factor Normal file
View File

@ -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

92
library/compiler/linearizer.factor
View File

@ -4,47 +4,11 @@ IN: compiler
USING: inference kernel lists math namespaces words strings USING: inference kernel lists math namespaces words strings
errors prettyprint kernel-internals ; 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 -- ) : >linear ( node -- )
#! Dataflow OPs have a linearizer word property. This #! Dataflow OPs have a linearizer word property. This
#! quotation is executed to convert the node into linear #! quotation is executed to convert the node into linear
#! form. #! form.
"linearizer" [ linear, ] apply-dataflow ; "linearizer" [ "No linearizer" throw ] apply-dataflow ;
: (linearize) ( dataflow -- ) : (linearize) ( dataflow -- )
[ >linear ] each ; [ >linear ] each ;
@ -55,19 +19,7 @@ SYMBOL: #prologue
#! jumps and labels, and turns dataflow IR nodes into #! jumps and labels, and turns dataflow IR nodes into
#! lists where the first element is an operation, and the #! lists where the first element is an operation, and the
#! rest is arguments. #! rest is arguments.
[ [ #prologue ] , (linearize) ] make-list ; [ %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
: <label> ( -- label ) : <label> ( -- label )
gensym dup t "label" set-word-prop ; gensym dup t "label" set-word-prop ;
@ -75,13 +27,10 @@ SYMBOL: #prologue
: label? ( obj -- ? ) : label? ( obj -- ? )
dup word? [ "label" word-prop ] [ drop f ] ifte ; dup word? [ "label" word-prop ] [ drop f ] ifte ;
: label, ( label -- )
#label swons , ;
: linearize-simple-label ( node -- ) : linearize-simple-label ( node -- )
#! Some labels become simple labels after the optimization #! Some labels become simple labels after the optimization
#! stage. #! stage.
dup [ node-label get ] bind label, dup [ node-label get ] bind %label ,
[ node-param get ] bind (linearize) ; [ node-param get ] bind (linearize) ;
#simple-label [ #simple-label [
@ -91,29 +40,36 @@ SYMBOL: #prologue
: linearize-label ( node -- ) : linearize-label ( node -- )
#! Labels are tricky, because they might contain non-tail #! Labels are tricky, because they might contain non-tail
#! calls. So we push the address of the location right after #! 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 #! node to the linear IR. The simplifier will take care of
#! this in the common case where the labelled block does #! this in the common case where the labelled block does
#! not contain non-tail recursive calls to itself. #! not contain non-tail recursive calls to itself.
<label> dup #return-to swons , >r <label> dup %return-to , >r
linearize-simple-label linearize-simple-label
[ #return ] , %return ,
r> label, ; r> %label , ;
#label [ #label [
linearize-label linearize-label
] "linearizer" set-word-prop ] "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 -- ) : linearize-ifte ( param -- )
#! The parameter is a list of two lists, each one a dataflow #! The parameter is a list of two lists, each one a dataflow
#! IR. #! IR.
2unlist <label> [ 2unlist <label> [
#jump-t-label swons , conditional
(linearize) ( false branch ) (linearize) ( false branch )
<label> dup #jump-label swons , <label> dup %jump-label ,
] keep label, ( branch target of BRANCH-T ) ] keep %label , ( branch target of BRANCH-T )
swap (linearize) ( true branch ) swap (linearize) ( true branch )
label, ( branch target of false branch end ) ; %label , ( branch target of false branch end ) ;
\ ifte [ \ ifte [
[ node-param get ] bind linearize-ifte [ node-param get ] bind linearize-ifte
@ -122,19 +78,19 @@ SYMBOL: #prologue
: dispatch-head ( vtable -- end label/code ) : dispatch-head ( vtable -- end label/code )
#! Output the jump table insn and return a list of #! Output the jump table insn and return a list of
#! label/branch pairs. #! label/branch pairs.
[ dispatch ] , %dispatch ,
<label> ( end label ) swap <label> ( end label ) swap
[ <label> dup #target-label swons , cons ] map [ <label> dup %target-label , cons ] map
[ #end-dispatch ] , ; %end-dispatch , ;
: dispatch-body ( end label/param -- ) : dispatch-body ( end label/param -- )
#! Output each branch, with a jump to the end label. #! 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 -- ) : linearize-dispatch ( vtable -- )
#! The parameter is a list of lists, each one is a branch to #! The parameter is a list of lists, each one is a branch to
#! take in case the top of stack has that type. #! take in case the top of stack has that type.
dispatch-head dupd dispatch-body label, ; dispatch-head dupd dispatch-body %label , ;
\ dispatch [ \ dispatch [
[ node-param get ] bind linearize-dispatch [ node-param get ] bind linearize-dispatch
@ -142,4 +98,4 @@ SYMBOL: #prologue
#values [ drop ] "linearizer" set-word-prop #values [ drop ] "linearizer" set-word-prop
#return [ drop [ #return ] , ] "linearizer" set-word-prop #return [ drop %return , ] "linearizer" set-word-prop

5
library/compiler/simplifier.factor
View File

@ -56,11 +56,6 @@ SYMBOL: simplifying
#! its param. #! its param.
over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ; 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 [ \ drop [
[ [
#push-immediate cancel [ #push-immediate cancel [

111
library/compiler/vops.factor Normal file
View File

@ -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> ;

8
library/compiler/x86/fixnum.factor
View File

@ -42,9 +42,6 @@ USE: math-internals
! values happends. At this point in time, this is just a ! values happends. At this point in time, this is just a
! prototype to test the assembler. ! prototype to test the assembler.
: self ( word -- )
f swap dup "infer-effect" word-prop (consume/produce) ;
: fixnum-insn ( overflow opcode -- ) : fixnum-insn ( overflow opcode -- )
#! This needs to be factored. #! This needs to be factored.
EAX [ ESI -4 ] MOV EAX [ ESI -4 ] MOV
@ -136,6 +133,11 @@ USE: math-internals
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop \ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-prop
: PUSH-DS ( -- )
#! Push EAX to datastack.
ESI 4 ADD
[ ESI ] EAX MOV ;
\ arithmetic-type [ \ arithmetic-type [
drop drop
EAX [ ESI -4 ] MOV EAX [ ESI -4 ] MOV

88
library/compiler/x86/generator.factor
View File

@ -2,45 +2,77 @@
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: assembler IN: assembler
USING: alien compiler inference kernel kernel-internals lists 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 ! Not used on x86
#prologue [ drop ] "generator" set-word-prop M: %prologue generate-node drop ;
\ slot [
PEEK-DS
2unlist type-tag >r cell * r> - EAX swap 2list EAX swap MOV
[ ESI ] EAX MOV
] "generator" set-word-prop
: compile-call-label ( label -- ) 0 CALL relative ; : compile-call-label ( label -- ) 0 CALL relative ;
: compile-jump-label ( label -- ) 0 JMP relative ; : compile-jump-label ( label -- ) 0 JMP relative ;
#call-label [ M: %call-label generate-node ( vop -- )
compile-call-label vop-label compile-call-label ;
] "generator" set-word-prop
#jump [ M: %jump generate-node ( vop -- )
dup postpone-word compile-jump-label vop-label dup postpone-word compile-jump-label ;
] "generator" set-word-prop
: compile-jump-t ( word -- ) M: %jump-f generate-node ( vop -- )
POP-DS dup vop-source v>operand f address CMP 0 JNE
! condition is now in EAX vop-label relative ;
EAX f address CMP
! jump w/ address added later
0 JNE relative ;
: compile-jump-f ( word -- ) M: %jump-t generate-node ( vop -- )
POP-DS dup vop-source v>operand f address CMP 0 JE
! condition is now in EAX vop-label relative ;
EAX f address CMP
! jump w/ address added later
0 JE 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 [ \ dispatch [
#! Compile a piece of code that jumps to an offset in a #! Compile a piece of code that jumps to an offset in a

132
library/compiler/x86/stack.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005 Slava Pestov. ! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: compiler IN: compiler
USING: inference kernel assembler words lists alien memory ; USING: alien assembler inference kernel lists math memory
sequences words ;
: rel-cs ( -- ) : rel-cs ( -- )
#! Add an entry to the relocation table for the 32-bit #! 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 MOV rel-cs ;
: >CS ( register -- ) CS swap MOV rel-cs ; : >CS ( register -- ) CS swap MOV rel-cs ;
: PEEK-DS ( -- ) : reg-stack ( reg n -- op ) cell * neg 2list ;
#! Peek datastack to EAX. : ds-op ( n -- op ) ESI swap reg-stack ;
EAX [ ESI ] MOV ; : rs-op ( n -- op ) ECX swap reg-stack ;
: POP-DS ( -- ) M: %peek-d generate-node ( vop -- )
#! Pop datastack to EAX. dup vop-dest v>operand swap vop-literal ds-op MOV ;
PEEK-DS
ESI 4 SUB ;
: PUSH-DS ( -- ) M: %dec-d generate-node ( vop -- )
#! Push EAX to datastack. vop-literal ESI swap cell * SUB ;
ESI 4 ADD
[ ESI ] EAX MOV ;
: PEEK-CS ( -- ) M: %replace-d generate-node ( vop -- )
#! Peek return stack to EAX. dup vop-source v>operand swap vop-literal ds-op swap MOV ;
ECX CS>
EAX [ ECX ] MOV ;
: POP-CS ( -- ) M: %inc-d generate-node ( vop -- )
#! Pop return stack to EAX. vop-literal ESI swap cell * ADD ;
PEEK-CS
ECX 4 SUB 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 ; ECX >CS ;
: PUSH-CS ( -- ) M: %inc-r generate-node ( vop -- )
#! Push EAX to return stack. #! Can only follow a %peek-r
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
ECX CS> ECX CS>
PUSH-CS vop-literal ECX swap cell * ADD ;
] "generator" set-word-prop
\ r> [
drop
POP-CS
PUSH-DS
] "generator" set-word-prop