core/compiler/x86/allot.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler
   4 USING: kernel assembler kernel-internals namespaces math ;
   5
   6 : load-zone-ptr ( -- )
   7     #! Load pointer to start of zone array
   8     allot-tmp-reg 0 MOV
   9     "generations" f rel-absolute-cell rel-dlsym
  10     allot-tmp-reg allot-tmp-reg [] MOV ;
  11
  12 : load-allot-ptr ( -- )
  13     load-zone-ptr
  14     allot-tmp-reg allot-tmp-reg cell [+] MOV ;
  15
  16 : inc-allot-ptr ( n -- )
  17     load-zone-ptr
  18     allot-tmp-reg cell [+] swap 8 align ADD ;
  19
  20 : store-header ( header -- )
  21     allot-tmp-reg [] swap tag-header MOV ;
  22
  23 : %allot ( header size quot -- )
  24     dup maybe-gc
  25     swap >r >r
  26     allot-tmp-reg PUSH
  27     load-allot-ptr
  28     store-header
  29     r> call
  30     r> inc-allot-ptr
  31     allot-tmp-reg POP ; inline
  32
  33 : %allot-float ( loc vreg -- )
  34     #! Only called by pentium4 backend, uses SSE2 instruction
  35     float-tag 16 [
  36         allot-tmp-reg 8 [+] swap v>operand MOVSD
  37         allot-tmp-reg float-tag OR
  38         v>operand allot-tmp-reg MOV
  39     ] %allot ;
  40
  41 : %allot-bignum ( #digits quot -- )
  42     #! 1 cell header, 1 cell length, 1 cell sign, + digits
  43     #! length is the # of digits + sign
  44     bignum-tag pick 3 + cells [
  45         ! Write length
  46         >r allot-tmp-reg cell [+] swap 1+ tag-bits shift MOV r>
  47         ! Call quot
  48         call
  49     ] %allot ; inline
  50
  51 : %allot-bignum-signed-1 ( outreg inreg -- )
  52     #! on entry, inreg is a signed 32-bit quantity
  53     #! exits with tagged ptr to bignum in outreg
  54     [
  55         "positive" define-label
  56         "end" define-label
  57         1 [
  58             dup 0 CMP
  59             "positive" get JGE
  60             allot-tmp-reg 2 cells [+] 1 MOV ! negative sign
  61             dup NEG
  62             "end" get JMP
  63             "positive" resolve-label
  64             allot-tmp-reg 2 cells [+] 0 MOV ! positive sign
  65             "end" resolve-label
  66             allot-tmp-reg 3 cells [+] swap MOV
  67             allot-tmp-reg bignum-tag OR
  68             allot-tmp-reg MOV
  69         ] %allot-bignum
  70     ] with-scope ;
  71
  72 : bignum-radix-mask 1 cell 2 - shift 1- ;
  73
  74 : %allot-bignum-signed-2 ( reg1 reg2 -- )
  75     #! this word has some hairy restrictions; its really only
  76     #! intended to be used by fixnum*.
  77     #! - reg1 and reg2 together form a 60-bit signed quantity
  78     #!   (product of two 29-bit fixnums cannot exceed this)
  79     #! - the quantity must be non-zero
  80     #!   (if the product of two fixnums is zero, there's no
  81     #!   overflow so this word won't be called in that case)
  82     #! exits with tagged ptr to bignum in reg1
  83     [
  84         "positive" define-label
  85         "end" define-label
  86         2 [
  87             0 pick CMP
  88             "positive" get JGE
  89             allot-tmp-reg 2 cells [+] 1 MOV
  90             over NOT
  91             dup -1 IMUL2
  92             "end" get JMP
  93             "positive" resolve-label
  94             allot-tmp-reg 2 cells [+] 0 MOV
  95             "end" resolve-label
  96             dup bignum-radix-mask AND
  97             allot-tmp-reg 3 cells [+] swap MOV
  98             dup bignum-radix-mask AND
  99             allot-tmp-reg 4 cells [+] over MOV
 100             allot-tmp-reg bignum-tag OR
 101             allot-tmp-reg MOV
 102         ] %allot-bignum
 103     ] with-scope ;