basis/cpu/x86/allot/allot.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel cpu.architecture cpu.x86.assembler
   4 cpu.x86.architecture kernel.private namespaces math sequences
   5 generic arrays compiler.generator compiler.generator.fixup
   6 compiler.generator.registers system layouts alien ;
   7 IN: cpu.x86.allot
   8
   9 : allot-reg ( -- reg )
  10     #! We temporarily use the datastack register, since it won't
  11     #! be accessed inside the quotation given to %allot in any
  12     #! case.
  13     ds-reg ;
  14
  15 : (object@) ( n -- operand ) allot-reg swap [+] ;
  16
  17 : object@ ( n -- operand ) cells (object@) ;
  18
  19 : load-zone-ptr ( reg -- )
  20     #! Load pointer to start of zone array
  21     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
  22
  23 : load-allot-ptr ( -- )
  24     allot-reg load-zone-ptr
  25     allot-reg PUSH
  26     allot-reg dup cell [+] MOV ;
  27
  28 : inc-allot-ptr ( n -- )
  29     allot-reg POP
  30     allot-reg cell [+] swap 8 align ADD ;
  31
  32 M: x86 %gc ( -- )
  33     "end" define-label
  34     temp-reg-1 load-zone-ptr
  35     temp-reg-2 temp-reg-1 cell [+] MOV
  36     temp-reg-2 1024 ADD
  37     temp-reg-1 temp-reg-1 3 cells [+] MOV
  38     temp-reg-2 temp-reg-1 CMP
  39     "end" get JLE
  40     0 frame-required
  41     %prepare-alien-invoke
  42     "minor_gc" f %alien-invoke
  43     "end" resolve-label ;
  44
  45 : store-header ( header -- )
  46     0 object@ swap type-number tag-fixnum MOV ;
  47
  48 : %allot ( header size quot -- )
  49     allot-reg PUSH
  50     swap >r >r
  51     load-allot-ptr
  52     store-header
  53     r> call
  54     r> inc-allot-ptr
  55     allot-reg POP ; inline
  56
  57 : %store-tagged ( reg tag -- )
  58     >r dup fresh-object v>operand r>
  59     allot-reg swap tag-number OR
  60     allot-reg MOV ;
  61
  62 M: x86 %box-float ( dst src -- )
  63     #! Only called by pentium4 backend, uses SSE2 instruction
  64     #! dest is a loc or a vreg
  65     float 16 [
  66         8 (object@) swap v>operand MOVSD
  67         float %store-tagged
  68     ] %allot ;
  69
  70 : %allot-bignum-signed-1 ( outreg inreg -- )
  71     #! on entry, inreg is a signed 32-bit quantity
  72     #! exits with tagged ptr to bignum in outreg
  73     #! 1 cell header, 1 cell length, 1 cell sign, + digits
  74     #! length is the # of digits + sign
  75     [
  76         { "end" "nonzero" "positive" "store" }
  77         [ define-label ] each
  78         dup v>operand 0 CMP ! is it zero?
  79         "nonzero" get JNE
  80         0 >bignum pick load-literal ! this is our result
  81         "end" get JMP
  82         "nonzero" resolve-label
  83         bignum 4 cells [
  84             ! Write length
  85             1 object@ 2 v>operand MOV
  86             ! Test sign
  87             dup v>operand 0 CMP
  88             "positive" get JGE
  89             2 object@ 1 MOV ! negative sign
  90             dup v>operand NEG
  91             "store" get JMP
  92             "positive" resolve-label
  93             2 object@ 0 MOV ! positive sign
  94             "store" resolve-label
  95             3 object@ swap v>operand MOV
  96             ! Store tagged ptr in reg
  97             bignum %store-tagged
  98         ] %allot
  99         "end" resolve-label
 100     ] with-scope ;
 101
 102 M: x86 %box-alien ( dst src -- )
 103     [
 104         { "end" "f" } [ define-label ] each
 105         dup v>operand 0 CMP
 106         "f" get JE
 107         alien 4 cells [
 108             1 object@ f v>operand MOV
 109             2 object@ f v>operand MOV
 110             ! Store src in alien-offset slot
 111             3 object@ swap v>operand MOV
 112             ! Store tagged ptr in dst
 113             dup object %store-tagged
 114         ] %allot
 115         "end" get JMP
 116         "f" resolve-label
 117         f [ v>operand ] bi@ MOV
 118         "end" resolve-label
 119     ] with-scope ;