diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index fecc087dae..91ac923273 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -512,13 +512,12 @@ temp: temp/int-rep ; PURE-INSN: ##box-displaced-alien def: dst/int-rep use: displacement/int-rep base/int-rep -temp: temp1/int-rep temp2/int-rep +temp: temp/int-rep literal: base-class ; PURE-INSN: ##unbox-any-c-ptr def: dst/int-rep -use: src/int-rep -temp: temp/int-rep ; +use: src/int-rep ; : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; @@ -527,12 +526,12 @@ PURE-INSN: ##unbox-alien def: dst/int-rep use: src/int-rep ; -: ##unbox-c-ptr ( dst src class temp -- ) +: ##unbox-c-ptr ( dst src class -- ) { - { [ over \ f class<= ] [ 2drop ##unbox-f ] } - { [ over alien class<= ] [ 2drop ##unbox-alien ] } - { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] } - [ nip ##unbox-any-c-ptr ] + { [ dup \ f class<= ] [ drop ##unbox-f ] } + { [ dup alien class<= ] [ drop ##unbox-alien ] } + { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] } + [ drop ##unbox-any-c-ptr ] } cond ; ! Alien accessors diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index fb993681e8..320a0a08f7 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien bi and ; : ^^unbox-c-ptr ( src class -- dst ) - [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; + [ next-vreg dup ] 2dip ##unbox-c-ptr ; : prepare-alien-accessor ( info -- ptr-vreg offset ) class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 4fd86c8e96..4864a8bfb7 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; :: rewrite-unbox-displaced-alien ( insn expr -- insns ) [ next-vreg :> temp - temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr + temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr insn dst>> temp expr displacement>> vn>vreg ##add ] { } make ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 75fbb85542..6723956780 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -386,9 +386,9 @@ M: object %horizontal-shl-vector-imm-reps { } ; M: object %horizontal-shr-vector-imm-reps { } ; HOOK: %unbox-alien cpu ( dst src -- ) -HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) +HOOK: %unbox-any-c-ptr cpu ( dst src -- ) HOOK: %box-alien cpu ( dst src temp -- ) -HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- ) +HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- ) HOOK: %alien-unsigned-1 cpu ( dst src offset -- ) HOOK: %alien-unsigned-2 cpu ( dst src offset -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index fc56113e90..5cd9ab2199 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -177,20 +177,20 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- ) M: x86 %unbox-alien ( dst src -- ) alien-offset [+] MOV ; -M:: x86 %unbox-any-c-ptr ( dst src temp -- ) +M:: x86 %unbox-any-c-ptr ( dst src -- ) [ "end" define-label - ! Compute tag in temp register - temp src MOV - temp tag-mask get AND - dst 0 MOV + dst dst XOR ! Is the object f? src \ f type-number CMP "end" get JE + ! Compute tag in dst register + dst src MOV + dst tag-mask get AND + ! Is the object an alien? + dst alien type-number CMP ! Add an offset to start of byte array's data dst src byte-array-offset [+] LEA - ! Is the object an alien? - temp alien type-number CMP "end" get JNE ! If so, load the offset and add it to the address dst src alien-offset [+] MOV @@ -203,7 +203,7 @@ M:: x86 %box-alien ( dst src temp -- ) [ "end" define-label dst \ f type-number MOV - src 0 CMP + src src TEST "end" get JE dst 5 cells alien temp %allot dst 1 alien@ \ f type-number MOV ! base @@ -213,32 +213,73 @@ M:: x86 %box-alien ( dst src temp -- ) "end" resolve-label ] with-scope ; -M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- ) +M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- ) + ! This is ridiculous [ "end" define-label - "ok" define-label + "not-f" define-label + "not-alien" define-label + ! If displacement is zero, return the base dst base MOV - displacement 0 CMP + displacement displacement TEST "end" get JE - ! Quickly use displacement' before its needed for real, as allot temporary - dst 4 cells alien displacement' %allot - ! If base is already a displaced alien, unpack it - base' base MOV - displacement' displacement MOV + + ! Displacement is non-zero, we're going to be allocating a new + ! object + dst 5 cells alien temp %allot + + ! Set expired to f + dst 2 alien@ \ f type-number MOV + + ! Is base f? base \ f type-number CMP - "ok" get JE - ! XXX - base 0 [+] alien type-number tag-fixnum CMP - "ok" get JNE - ! displacement += base.displacement - displacement' base 3 alien@ ADD - ! base = base.base - base' base 1 alien@ MOV - "ok" resolve-label - dst 1 alien@ base' MOV ! alien - dst 2 alien@ \ f type-number MOV ! expired - dst 3 alien@ displacement' MOV ! displacement + "not-f" get JNE + + ! Yes, it is f. Fill in new object + dst 1 alien@ base MOV + dst 3 alien@ displacement MOV + dst 4 alien@ displacement MOV + + "end" get JMP + + "not-f" resolve-label + + ! Check base type + temp base MOV + temp tag-mask get AND + + ! Is base an alien? + temp alien type-number CMP + "not-alien" get JNE + + ! Yes, it is an alien. Set new alien's base to base.base + temp base 1 alien@ MOV + dst 1 alien@ temp MOV + + ! Compute displacement + temp base 3 alien@ MOV + temp displacement ADD + dst 3 alien@ temp MOV + + ! Compute address + temp base 4 alien@ MOV + temp displacement ADD + dst 4 alien@ temp MOV + + ! We are done + "end" get JMP + + ! Is base a byte array? It has to be, by now... + "not-alien" resolve-label + + dst 1 alien@ base MOV + dst 3 alien@ displacement MOV + temp base MOV + temp byte-array-offset ADD + temp displacement ADD + dst 4 alien@ temp MOV + "end" resolve-label ] with-scope ;