basis/cpu/ppc/allot/allot.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel cpu.ppc.architecture cpu.ppc.assembler
   4 kernel.private namespaces math sequences generic arrays
   5 generator generator.registers generator.fixup system layouts
   6 cpu.architecture alien ;
   7 IN: cpu.ppc.allot
   8
   9 : load-zone-ptr ( reg -- )
  10     >r "nursery" f r> %load-dlsym ;
  11
  12 : %allot ( header size -- )
  13     #! Store a pointer to 'size' bytes allocated from the
  14     #! nursery in r11.
  15     8 align ! align the size
  16     12 load-zone-ptr ! nusery -> r12
  17     11 12 cell LWZ ! nursery.here -> r11
  18     11 11 pick ADDI ! increment r11
  19     11 12 cell STW ! r11 -> nursery.here
  20     11 11 rot SUBI ! old value
  21     type-number tag-fixnum 12 LI ! compute header
  22     12 11 0 STW ! store header
  23     ;
  24
  25 : %store-tagged ( reg tag -- )
  26     >r dup fresh-object v>operand 11 r> tag-number ORI ;
  27
  28 M: ppc %gc
  29     "end" define-label
  30     12 load-zone-ptr
  31     11 12 cell LWZ ! nursery.here -> r11
  32     12 12 3 cells LWZ ! nursery.end -> r12
  33     11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
  34     11 0 12 CMP ! is here >= end?
  35     "end" get BLE
  36     0 frame-required
  37     %prepare-alien-invoke
  38     "minor_gc" f %alien-invoke
  39     "end" resolve-label ;
  40
  41 : %allot-float ( reg -- )
  42     #! exits with tagged ptr to object in r12, untagged in r11
  43     float 16 %allot
  44     11 8 STFD
  45     12 11 float tag-number ORI
  46     f fresh-object ;
  47
  48 M: ppc %box-float ( dst src -- )
  49     [ v>operand ] bi@ %allot-float 12 MR ;
  50
  51 : %allot-bignum ( #digits -- )
  52     #! 1 cell header, 1 cell length, 1 cell sign, + digits
  53     #! length is the # of digits + sign
  54     bignum over 3 + cells %allot
  55     1+ v>operand 12 LI ! compute the length
  56     12 11 cell STW ! store the length
  57     ;
  58
  59 : %allot-bignum-signed-1 ( reg -- )
  60     #! on entry, reg is a 30-bit quantity sign-extended to
  61     #! 32-bits.
  62     #! exits with tagged ptr to bignum in reg
  63     [
  64         { "end" "non-zero" "pos" "store" } [ define-label ] each
  65         ! is it zero?
  66         0 over v>operand 0 CMPI
  67         "non-zero" get BNE
  68         0 >bignum over load-literal
  69         "end" get B
  70         ! it is non-zero
  71         "non-zero" resolve-label
  72         1 %allot-bignum
  73         ! is the fixnum negative?
  74         0 over v>operand 0 CMPI
  75         "pos" get BGE
  76         1 12 LI
  77         ! store negative sign
  78         12 11 2 cells STW
  79         ! negate fixnum
  80         dup v>operand dup -1 MULI
  81         "store" get B
  82         "pos" resolve-label
  83         0 12 LI
  84         ! store positive sign
  85         12 11 2 cells STW
  86         "store" resolve-label
  87         ! store the number
  88         dup v>operand 11 3 cells STW
  89         ! tag the bignum, store it in reg
  90         bignum %store-tagged
  91         "end" resolve-label
  92     ] with-scope ;
  93
  94 M: ppc %box-alien ( dst src -- )
  95     { "end" "f" } [ define-label ] each
  96     0 over v>operand 0 CMPI
  97     "f" get BEQ
  98     alien 4 cells %allot
  99     ! Store offset
 100     v>operand 11 3 cells STW
 101     f v>operand 12 LI
 102     ! Store expired slot
 103     12 11 1 cells STW
 104     ! Store underlying-alien slot
 105     12 11 2 cells STW
 106     ! Store tagged ptr in reg
 107     dup object %store-tagged
 108     "end" get B
 109     "f" resolve-label
 110     f v>operand swap v>operand LI
 111     "end" resolve-label ;