From 706c5d825a2664dd7456ab12bf368a0f4e6c16d9 Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Sun, 30 Apr 2006 20:13:35 +0000
Subject: [PATCH] First approximation at x86 intrinsic definitions

---
 library/compiler/x86/intrinsics.factor | 393 ++++++++++++++-----------
 1 file changed, 221 insertions(+), 172 deletions(-)

diff --git a/library/compiler/x86/intrinsics.factor b/library/compiler/x86/intrinsics.factor
index 2bb78d6c15..7e41ac6564 100644
--- a/library/compiler/x86/intrinsics.factor
+++ b/library/compiler/x86/intrinsics.factor
@@ -1,221 +1,270 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences ;
 
-M: %type generate-node ( vop -- )
+\ tag [
+    "in" operand tag-mask AND
+    "in" operand tag-bits SHL
+] H{
+    { +input { { f "in" } } }
+    { +output { "in" } }
+} define-intrinsic
+
+\ type [
     #! Intrinstic version of type primitive.
-    drop
     <label> "header" set
     <label> "f" set
     <label> "end" set
     ! Make a copy
-    0 scratch 0 output-operand MOV
+    "x" operand "obj" operand MOV
     ! Get the tag
-    0 output-operand tag-mask AND
+    "obj" operand tag-mask AND
     ! Compare with object tag number (3).
-    0 output-operand object-tag CMP
+    "obj" operand object-tag CMP
     ! Jump if the object doesn't store type info in its header
     "header" get JE
     ! It doesn't store type info in its header
-    0 output-operand tag-bits SHL
+    "obj" operand tag-bits SHL
     "end" get JMP
     "header" get save-xt
     ! It does store type info in its header
     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 scratch object-tag CMP
+    "x" operand object-tag CMP
     "f" get JE
     ! The pointer is not equal to 3. Load the object header.
-    0 output-operand 0 scratch object-tag neg [+] MOV
+    "obj" operand "x" operand object-tag neg [+] MOV
     ! Mask off header tag, making a fixnum.
-    0 output-operand object-tag XOR
+    "obj" operand object-tag XOR
     "end" get JMP
     "f" get save-xt
     ! The pointer is equal to 3. Load F_TYPE (9).
-    0 output-operand f type tag-bits shift MOV
-    "end" get save-xt ;
+    "obj" operand f type tag-bits shift MOV
+    "end" get save-xt
+] H{
+    { +input { { f "obj" } } }
+    { +scratch { { f "x" } { f "y" } } }
+    { +output { "obj" } }
+} define-intrinsic
 
-M: %tag generate-node ( vop -- )
-    drop
-    0 input-operand tag-mask AND
-    0 input-operand tag-bits SHL ;
+: untag ( reg -- ) tag-mask bitnot AND ;
 
-M: %untag generate-node ( vop -- )
-    drop
-    0 output-operand tag-mask bitnot AND ;
-
-M: %slot generate-node ( vop -- )
-    drop
+\ slot [
+    "obj" operand untag
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    0 input-operand fixnum>slot@
+    "n" operand fixnum>slot@
     ! compute slot address
-    dest/src ADD
+    "obj" operand "n" operand ADD
     ! load slot value
-    0 output-operand dup [] MOV ;
+    "obj" operand dup [] MOV
+] H{
+    { +input { { f "obj" } { f "n" } } }
+    { +output { "obj" } }
+    { +clobber { "n" } }
+} define-intrinsic
 
 : card-offset 1 getenv ; inline
 
-M: %write-barrier generate-node ( vop -- )
+: generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
-    drop
-    0 input-operand card-bits SHR
-    0 input-operand card-offset ADD rel-absolute-cell rel-cards
-    0 input-operand [] card-mark OR ;
+    "obj" operand card-bits SHR
+    "obj" operand card-offset ADD rel-absolute-cell rel-cards
+    "obj" operand [] card-mark OR ;
 
-M: %set-slot generate-node ( vop -- )
-    drop
+\ set-slot [
+    "obj" operand untag
     ! turn tagged fixnum slot # into an offset
-    2 input-operand fixnum>slot@
+    "slot" operand fixnum>slot@
     ! compute slot address
-    2 input-operand 1 input-operand ADD
+    "obj" operand "slot" operand ADD
     ! store new slot value
-    2 input-operand [] 0 input-operand MOV ;
+    "obj" operand [] "val" operand MOV
+    generate-write-barrier
+] H{
+    { +input { { f "val" } { f "obj" } { f "slot" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
 
-: >register-16 ( reg -- reg )
-    "register" word-prop { AX CX DX } nth ;
+\ char-slot [
+    EBX PUSH
+    "n" operand 2 SHR
+    EBX dup XOR
+    EBX "n" operand ADD
+    BX "obj" operand string-offset [+] MOV
+    EBX tag-bits SHL
+    "obj" operand EBX MOV
+    EBX POP
+] H{
+    { +input { { f "n" } { f "obj" } } }
+    { +output { "obj" } }
+    { +clobber { "n" } }
+} define-intrinsic
 
-: scratch-16 ( n -- reg ) scratch >register-16 ;
+\ set-char-slot [
+    "obj" operand untag
+    EBX PUSH
+    "val" operand tag-bits SHR
+    "slot" operand 2 SHR
+    "obj" operand "slot" operand ADD
+    EBX "val" operand MOV
+    "obj" operand string-offset [+] BX MOV
+    EBX POP
+] H{
+    { +input { { f "val" } { f "slot" } { f "obj" } } }
+    { +clobber { "obj" } }
+} define-intrinsic
 
-M: %char-slot generate-node ( vop -- )
-    drop
-    0 input-operand 2 SHR
-    0 scratch dup XOR
-    dest/src ADD
-    0 scratch-16 0 output-operand string-offset [+] MOV
-    0 scratch tag-bits SHL
-    0 output-operand 0 scratch MOV ;
+: define-binary-op ( word op -- )
+    [ [ "x" operand "y" operand ] % , ] [ ] make H{
+        { +input { { f "x" } { f "y" } } }
+        { +output { "x" } }
+    } define-intrinsic ;
 
-M: %set-char-slot generate-node ( vop -- )
-    drop
-    0 input-operand tag-bits SHR
-    2 input-operand 2 SHR
-    2 input-operand 1 input-operand ADD
-    2 input-operand string-offset [+]
-    0 input-operand >register-16 MOV ;
+{
+    { fixnum+fast ADD }
+    { fixnum-fast SUB }
+    { fixnum-bitand AND }
+    { fixnum-bitor OR }
+    { fixnum-bitxor XOR }
+} [
+    first2 define-binary-op
+] each
 
-: literal-overflow ( -- dest src )
-    #! Called if the src operand is a literal.
-    #! Untag the dest operand.
-    dest/src over tag-bits SAR tag-bits neg shift ;
+\ fixnum-bitnot [
+    "x" operand NOT
+    "x" operand tag-mask XOR
+] H{
+    { +input { { f "x" } } }
+    { +output { "x" } }
+} define-intrinsic
 
-: computed-overflow ( -- dest src )
-    #! Called if the src operand is a register.
-    #! Untag both operands.
-    dest/src 2dup tag-bits SAR tag-bits SAR ;
-
-: simple-overflow ( inverse word -- )
-    #! If the previous arithmetic operation overflowed, then we
-    #! turn the result into a bignum and leave it in EAX.
-    <label> "end" set
-    "end" get JNO
-    ! There was an overflow. Recompute the original operand.
-    >r >r dest/src r> execute
-    0 input integer? [ literal-overflow ] [ computed-overflow ] if
-    ! Compute a result, this time it will fit.
-    r> execute
-    ! Create a bignum.
-    "s48_long_to_bignum" f 0 output-operand
-    1array compile-c-call*
-    ! An untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    "end" get save-xt ; inline
-
-M: %fixnum+ generate-node ( vop -- )
-    drop dest/src ADD  \ SUB \ ADD simple-overflow ;
-
-M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
-
-M: %fixnum- generate-node ( vop -- )
-    drop dest/src SUB  \ ADD \ SUB simple-overflow ;
-
-M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
-
-M: %fixnum* generate-node ( vop -- )
-    drop
-    ! both inputs are tagged, so one of them needs to have its
-    ! tag removed.
-    1 input-operand tag-bits SAR
-    0 input-operand IMUL
-    <label> "end" set
-    "end" get JNO
-    "s48_fixnum_pair_to_bignum" f
-    1 input-operand remainder-reg 2array compile-c-call*
-    ! now we have to shift it by three bits to remove the second
-    ! tag
-    "s48_bignum_arithmetic_shift" f
-    1 input-operand tag-bits neg 2array compile-c-call*
-    ! an untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    "end" get save-xt ;
-
-M: %fixnum-mod generate-node ( vop -- )
-    #! This has specific register requirements. Inputs are in
-    #! ECX and EAX, and the result is in EDX.
-    drop
+! This has specific register requirements. Inputs are in
+! ECX and EAX, and the result is in EDX.
+\ fixnum-mod [
     prepare-division
-    0 input-operand IDIV ;
+    "x" operand IDIV
+] H{
+    { +input { { 0 "x" } { 2 "y" } } }
+    { +output { "x" } }
+} define-intrinsic
 
-: generate-fixnum/mod
-    #! The same code is used for %fixnum/i and %fixnum/mod.
-    #! This has specific register requirements. Inputs are in
-    #! ECX and EAX, and the result is in EDX.
-    <label> "end" set
-    prepare-division
-    0 input-operand IDIV
-    ! Make a copy since following shift is destructive
-    0 input-operand 1 input-operand MOV
-    ! Tag the value, since division cancelled tags from both
-    ! inputs
-    1 input-operand tag-bits SHL
-    ! Did it overflow?
-    "end" get JNO
-    ! There was an overflow, so make ECX into a bignum. we must
-    ! save EDX since its volatile.
-    remainder-reg PUSH
-    "s48_long_to_bignum" f
-    0 input-operand 1array compile-c-call*
-    ! An untagged pointer to the bignum is now in EAX; tag it
-    T{ int-regs } return-reg bignum-tag OR
-    ! the remainder is now in EDX
-    remainder-reg POP
-    "end" get save-xt ;
+! : literal-overflow ( -- dest src )
+!     #! Called if the src operand is a literal.
+!     #! Untag the dest operand.
+!     dest/src over tag-bits SAR tag-bits neg shift ;
+! 
+! : computed-overflow ( -- dest src )
+!     #! Called if the src operand is a register.
+!     #! Untag both operands.
+!     dest/src 2dup tag-bits SAR tag-bits SAR ;
+! 
+! : simple-overflow ( inverse word -- )
+!     #! If the previous arithmetic operation overflowed, then we
+!     #! turn the result into a bignum and leave it in EAX.
+!     <label> "end" set
+!     "end" get JNO
+!     ! There was an overflow. Recompute the original operand.
+!     >r >r dest/src r> execute
+!     0 input integer? [ literal-overflow ] [ computed-overflow ] if
+!     ! Compute a result, this time it will fit.
+!     r> execute
+!     ! Create a bignum.
+!     "s48_long_to_bignum" f 0 output-operand
+!     1array compile-c-call*
+!     ! An untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     "end" get save-xt ; inline
+! 
+! M: %fixnum+ generate-node ( vop -- )
+!     drop dest/src ADD  \ SUB \ ADD simple-overflow ;
+! 
+! M: %fixnum- generate-node ( vop -- )
+!     drop dest/src SUB  \ ADD \ SUB simple-overflow ;
+! 
+! M: %fixnum* generate-node ( vop -- )
+!     drop
+!     ! both inputs are tagged, so one of them needs to have its
+!     ! tag removed.
+!     1 input-operand tag-bits SAR
+!     0 input-operand IMUL
+!     <label> "end" set
+!     "end" get JNO
+!     "s48_fixnum_pair_to_bignum" f
+!     1 input-operand remainder-reg 2array compile-c-call*
+!     ! now we have to shift it by three bits to remove the second
+!     ! tag
+!     "s48_bignum_arithmetic_shift" f
+!     1 input-operand tag-bits neg 2array compile-c-call*
+!     ! an untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     "end" get save-xt ;
+! 
+! : generate-fixnum/mod
+!     #! The same code is used for %fixnum/i and %fixnum/mod.
+!     #! This has specific register requirements. Inputs are in
+!     #! ECX and EAX, and the result is in EDX.
+!     <label> "end" set
+!     prepare-division
+!     0 input-operand IDIV
+!     ! Make a copy since following shift is destructive
+!     0 input-operand 1 input-operand MOV
+!     ! Tag the value, since division cancelled tags from both
+!     ! inputs
+!     1 input-operand tag-bits SHL
+!     ! Did it overflow?
+!     "end" get JNO
+!     ! There was an overflow, so make ECX into a bignum. we must
+!     ! save EDX since its volatile.
+!     remainder-reg PUSH
+!     "s48_long_to_bignum" f
+!     0 input-operand 1array compile-c-call*
+!     ! An untagged pointer to the bignum is now in EAX; tag it
+!     T{ int-regs } return-reg bignum-tag OR
+!     ! the remainder is now in EDX
+!     remainder-reg POP
+!     "end" get save-xt ;
+! 
+! M: %fixnum/i generate-node drop generate-fixnum/mod ;
+! 
+! M: %fixnum/mod generate-node drop generate-fixnum/mod ;
 
-M: %fixnum/i generate-node drop generate-fixnum/mod ;
+: define-binary-jump ( word op -- )
+    [
+        [ end-basic-block "x" operand "y" operand CMP ] % ,
+    ] [ ] make H{
+        { +input { { f "x" } { f "y" } } }
+    } define-if-intrinsic ;
 
-M: %fixnum/mod generate-node drop generate-fixnum/mod ;
+{
+    { fixnum< JL }
+    { fixnum<= JLE }
+    { fixnum> JG }
+    { fixnum>= JGE }
+    { eq? JE }
+} [
+    first2 define-binary-jump
+] each
 
-M: %fixnum-bitand generate-node ( vop -- ) drop dest/src AND ;
+: %userenv ( -- )
+    "x" operand "userenv" f dlsym MOV
+    rel-absolute-cell rel-userenv
+    "n" operand 1 SHR
+    "n" operand "x" operand ADD ;
 
-M: %fixnum-bitor generate-node ( vop -- ) drop dest/src OR ;
+\ getenv [
+    %userenv  "n" operand dup [] MOV
+] H{
+    { +input { { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +output { "n" } }
+} define-intrinsic
 
-M: %fixnum-bitxor generate-node ( vop -- ) drop dest/src XOR ;
-
-M: %fixnum-bitnot generate-node ( vop -- )
-    drop
-    ! Negate the bits of the operand
-    0 output-operand NOT
-    ! Mask off the low 3 bits to give a fixnum tag
-    0 output-operand tag-mask XOR ;
-
-M: %fixnum>> generate-node
-    drop
-    ! shift register
-    0 output-operand 0 input SAR
-    ! give it a fixnum tag
-    0 output-operand tag-mask bitnot AND ;
-
-M: %fixnum-sgn generate-node
-    #! This has specific register requirements.
-    drop
-    ! store 0 in EDX if EAX is >=0, otherwise store -1.
-    prepare-division
-    ! give it a fixnum tag.
-    0 output-operand tag-bits SHL ;
-
-: fixnum-jump ( -- label )
-    1 input-operand 0 input-operand CMP label ;
-
-M: %jump-fixnum<  generate-node ( vop -- ) drop fixnum-jump JL ;
-M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump JLE ;
-M: %jump-fixnum>  generate-node ( vop -- ) drop fixnum-jump JG ;
-M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump JGE ;
-M: %jump-eq?      generate-node ( vop -- ) drop fixnum-jump JE ;
+\ setenv [
+    %userenv  "n" operand [] "val" operand MOV
+] H{
+    { +input { { f "val" } { f "n" } } }
+    { +scratch { { f "x" } } }
+    { +clobber { "n" } }
+} define-intrinsic