core/compiler/x86/intrinsics.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays assembler kernel kernel-internals math
   4 math-internals namespaces sequences words ;
   5 IN: compiler
   6
   7 ! Type checks
   8 \ tag [
   9     "in" operand tag-mask AND
  10     "in" operand tag-bits SHL
  11 ] H{
  12     { +input+ { { f "in" } } }
  13     { +output+ { "in" } }
  14 } define-intrinsic
  15
  16 \ type [
  17     #! Intrinstic version of type primitive.
  18     "header" define-label
  19     "f" define-label
  20     "end" define-label
  21     ! Make a copy
  22     "x" operand "obj" operand MOV
  23     ! Get the tag
  24     "obj" operand tag-mask AND
  25     ! Compare with object tag number (3).
  26     "obj" operand object-tag CMP
  27     ! Jump if the object doesn't store type info in its header
  28     "header" get JE
  29     ! It doesn't store type info in its header
  30     "obj" operand tag-bits SHL
  31     "end" get JMP
  32     "header" resolve-label
  33     ! It does store type info in its header
  34     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
  35     "x" operand object-tag CMP
  36     "f" get JE
  37     ! The pointer is not equal to 3. Load the object header.
  38     "obj" operand "x" operand object-tag neg [+] MOV
  39     ! Mask off header tag, making a fixnum.
  40     "obj" operand object-tag XOR
  41     "end" get JMP
  42     "f" resolve-label
  43     ! The pointer is equal to 3. Load F_TYPE (9).
  44     "obj" operand f type tag-bits shift MOV
  45     "end" resolve-label
  46 ] H{
  47     { +input+ { { f "obj" } } }
  48     { +scratch+ { { f "x" } { f "y" } } }
  49     { +output+ { "obj" } }
  50 } define-intrinsic
  51
  52 ! Slots
  53 : %untag ( reg -- ) tag-mask bitnot AND ;
  54
  55 \ slot [
  56     "obj" operand %untag
  57     ! turn tagged fixnum slot # into an offset, multiple of 4
  58     "n" operand fixnum>slot@
  59     ! compute slot address
  60     "obj" operand "n" operand ADD
  61     ! load slot value
  62     "obj" operand dup [] MOV
  63 ] H{
  64     { +input+ { { f "obj" } { f "n" } } }
  65     { +output+ { "obj" } }
  66     { +clobber+ { "n" } }
  67 } define-intrinsic
  68
  69 : generate-write-barrier ( -- )
  70     #! Mark the card pointed to by vreg.
  71     "obj" operand card-bits SHR
  72     "obj" operand HEX: ffff ADD rel-absolute-cell rel-cards
  73     "obj" operand [] card-mark OR ;
  74
  75 \ set-slot [
  76     "obj" operand %untag
  77     ! turn tagged fixnum slot # into an offset
  78     "slot" operand fixnum>slot@
  79     ! compute slot address
  80     "slot" operand "obj" operand ADD
  81     ! store new slot value
  82     "slot" operand [] "val" operand MOV
  83     generate-write-barrier
  84 ] H{
  85     { +input+ { { f "val" } { f "obj" } { f "slot" } } }
  86     { +clobber+ { "obj" "slot" } }
  87 } define-intrinsic
  88
  89 : char-reg cell 8 = RBX EBX ? ; inline
  90 : char-reg-16 BX ; inline
  91
  92 \ char-slot [
  93     char-reg PUSH
  94     "n" operand 2 SHR
  95     char-reg dup XOR
  96     "obj" operand "n" operand ADD
  97     char-reg-16 "obj" operand string-offset [+] MOV
  98     char-reg tag-bits SHL
  99     "obj" operand char-reg MOV
 100     char-reg POP
 101 ] H{
 102     { +input+ { { f "n" } { f "obj" } } }
 103     { +output+ { "obj" } }
 104     { +clobber+ { "n" } }
 105 } define-intrinsic
 106
 107 \ set-char-slot [
 108     char-reg PUSH
 109     "val" operand tag-bits SHR
 110     "slot" operand 2 SHR
 111     "obj" operand "slot" operand ADD
 112     char-reg "val" operand MOV
 113     "obj" operand string-offset [+] char-reg-16 MOV
 114     char-reg POP
 115 ] H{
 116     { +input+ { { f "val" } { f "slot" } { f "obj" } } }
 117     { +clobber+ { "val" "slot" "obj" } }
 118 } define-intrinsic
 119
 120 ! Fixnums
 121 : define-fixnum-op ( word op -- )
 122     [ [ "x" operand "y" operand ] % , ] [ ] make H{
 123         { +input+ { { f "x" } { f "y" } } }
 124         { +output+ { "x" } }
 125     } define-intrinsic ;
 126
 127 {
 128     { fixnum+fast ADD }
 129     { fixnum-fast SUB }
 130     { fixnum-bitand AND }
 131     { fixnum-bitor OR }
 132     { fixnum-bitxor XOR }
 133 } [
 134     first2 define-fixnum-op
 135 ] each
 136
 137 \ fixnum-bitnot [
 138     "x" operand NOT
 139     "x" operand tag-mask XOR
 140 ] H{
 141     { +input+ { { f "x" } } }
 142     { +output+ { "x" } }
 143 } define-intrinsic
 144
 145 ! This has specific register requirements. Inputs are in
 146 ! ECX and EAX, and the result is in EDX.
 147 \ fixnum-mod [
 148     prepare-division
 149     "y" operand IDIV
 150 ] H{
 151     { +input+ { { 0 "x" } { 1 "y" } } }
 152     { +scratch+ { { 2 "out" } } }
 153     { +output+ { "out" } }
 154 } define-intrinsic
 155
 156 : %untag-fixnums ( seq -- )
 157     [ tag-bits SAR ] unique-operands ;
 158
 159 : simple-overflow ( word -- )
 160     "end" define-label
 161     "z" operand "x" operand MOV
 162     "z" operand "y" operand pick execute
 163     ! If the previous arithmetic operation overflowed, then we
 164     ! turn the result into a bignum and leave it in EAX.
 165     "end" get JNO
 166     ! There was an overflow. Recompute the original operand.
 167     { "y" "x" } %untag-fixnums
 168     "x" operand "y" operand rot execute
 169     "z" operand "x" operand %allot-bignum-signed-1
 170     "end" resolve-label ; inline
 171
 172 : simple-overflow-template ( word insn -- )
 173     [ simple-overflow ] curry H{
 174         { +input+ { { f "x" } { f "y" } } }
 175         { +scratch+ { { f "z" } } }
 176         { +output+ { "z" } }
 177         { +clobber+ { "x" "y" } }
 178     } define-intrinsic ;
 179
 180 \ fixnum+ \ ADD simple-overflow-template
 181 \ fixnum- \ SUB simple-overflow-template
 182
 183 : %tag-overflow ( -- )
 184     #! Tag a cell-size value, where the tagging might posibly
 185     #! overflow BUT IT MUST NOT EXCEED cell-2 BITS
 186     "y" operand "x" operand MOV ! Make a copy
 187     "x" operand 1 tag-bits shift IMUL2 ! Tag it
 188     "end" get JNO ! Overflow?
 189     "x" operand "y" operand %allot-bignum-signed-1 ! Yes, box bignum
 190     ;
 191
 192 ! \ fixnum* [
 193 !     "overflow-1" define-label
 194 !     "overflow-2" define-label
 195 !     "end" define-label
 196 !     { "y" "x" } %untag-fixnums
 197 !     "y" operand IMUL
 198 !     "overflow-1" get JNO
 199 !     "x" operand "r" operand %allot-bignum-signed-2
 200 !     "end" get JMP
 201 !     "overflow-1" resolve-label
 202 !     %tag-overflow
 203 !     "end" resolve-label
 204 ! ] H{
 205 !     { +input+ { { 0 "x" } { 1 "y" } } }
 206 !     { +output+ { "x" } }
 207 !     { +scratch+ { { 2 "r" } } }
 208 !     { +clobber+ { "y" } }
 209 ! } define-intrinsic
 210
 211 : generate-fixnum/mod
 212     #! The same code is used for fixnum/i and fixnum/mod.
 213     #! This has specific register
 214     #! ECX and EAX, and the result is in EDX.
 215     "end" define-label
 216     prepare-division
 217     "y" operand IDIV
 218     %tag-overflow
 219     "end" resolve-label ;
 220
 221 \ fixnum/i [ generate-fixnum/mod ] H{
 222     { +input+ { { 0 "x" } { 1 "y" } } }
 223     { +scratch+ { { 2 "r" } } }
 224     { +output+ { "x" } }
 225     { +clobber+ { "x" "y" } }
 226 } define-intrinsic
 227
 228 \ fixnum/mod [ generate-fixnum/mod ] H{
 229     { +input+ { { 0 "x" } { 1 "y" } } }
 230     { +scratch+ { { 2 "r" } } }
 231     { +output+ { "x" "r" } }
 232     { +clobber+ { "x" "y" } }
 233 } define-intrinsic
 234
 235 : define-fixnum-jump ( word op -- )
 236     [ "x" operand "y" operand CMP ] swap add
 237     { { f "x" } { f "y" } } define-if-intrinsic ;
 238
 239 {
 240     { fixnum< JL }
 241     { fixnum<= JLE }
 242     { fixnum> JG }
 243     { fixnum>= JGE }
 244     { eq? JE }
 245 } [
 246     first2 define-fixnum-jump
 247 ] each
 248
 249 \ fixnum>bignum [
 250     "nonzero" define-label
 251     "end" define-label
 252     "x" operand 0 CMP ! is it zero?
 253     "nonzero" get JNE
 254     0 >bignum "x" get load-literal
 255     "end" get JMP
 256     "nonzero" resolve-label
 257     "x" operand tag-bits SAR
 258     "x" operand dup %allot-bignum-signed-1
 259     "end" resolve-label
 260 ] H{
 261     { +input+ { { f "x" } } }
 262     { +output+ { "x" } }
 263 } define-intrinsic
 264
 265 \ bignum>fixnum [
 266     "nonzero" define-label
 267     "positive" define-label
 268     "end" define-label
 269     "x" operand %untag
 270     "y" operand "x" operand cell [+] MOV
 271      ! if the length is 1, its just the sign and nothing else,
 272      ! so output 0
 273     "y" operand 1 tag-bits shift CMP
 274     "nonzero" get JNE
 275     "y" operand 0 MOV
 276     "end" get JMP
 277     "nonzero" resolve-label
 278     ! load the value
 279     "y" operand "x" operand 3 cells [+] MOV
 280     ! load the sign
 281     "x" operand "x" operand 2 cells [+] MOV
 282     ! is the sign negative?
 283     "x" operand 0 CMP
 284     "positive" get JE
 285     "y" operand -1 IMUL2
 286     "positive" resolve-label
 287     "y" operand 3 SHL
 288     "end" resolve-label
 289 ] H{
 290     { +input+ { { f "x" } } }
 291     { +scratch+ { { f "y" } } }
 292     { +clobber+ { "x" } }
 293     { +output+ { "y" } }
 294 } define-intrinsic
 295
 296 ! User environment
 297 : %userenv ( -- )
 298     "x" operand 0 MOV
 299     "userenv" f rel-absolute-cell rel-dlsym
 300     "n" operand fixnum>slot@
 301     "n" operand "x" operand ADD ;
 302
 303 \ getenv [
 304     %userenv  "n" operand dup [] MOV
 305 ] H{
 306     { +input+ { { f "n" } } }
 307     { +scratch+ { { f "x" } } }
 308     { +output+ { "n" } }
 309 } define-intrinsic
 310
 311 \ setenv [
 312     %userenv  "n" operand [] "val" operand MOV
 313 ] H{
 314     { +input+ { { f "val" } { f "n" } } }
 315     { +scratch+ { { f "x" } } }
 316     { +clobber+ { "n" } }
 317 } define-intrinsic