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