basis/cpu/ppc/architecture/architecture.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types cpu.ppc.assembler
   4 cpu.architecture generic kernel kernel.private math memory
   5 namespaces sequences words assocs compiler.generator
   6 compiler.generator.registers compiler.generator.fixup system
   7 layouts classes words.private alien combinators
   8 compiler.constants math.order make ;
   9 IN: cpu.ppc.architecture
  10
  11 ! PowerPC register assignments
  12 ! r3-r10, r16-r31: integer vregs
  13 ! f0-f13: float vregs
  14 ! r11, r12: scratch
  15 ! r14: data stack
  16 ! r15: retain stack
  17
  18 : ds-reg 14 ; inline
  19 : rs-reg 15 ; inline
  20
  21 : reserved-area-size ( -- n )
  22     os {
  23         { linux [ 2 ] }
  24         { macosx [ 6 ] }
  25     } case cells ; foldable
  26
  27 : lr-save ( -- n )
  28     os {
  29         { linux [ 1 ] }
  30         { macosx [ 2 ] }
  31     } case cells ; foldable
  32
  33 : param@ ( n -- x ) reserved-area-size + ; inline
  34
  35 : param-save-size ( -- n ) 8 cells ; foldable
  36
  37 : local@ ( n -- x )
  38     reserved-area-size param-save-size + + ; inline
  39
  40 : factor-area-size ( -- n ) 2 cells ; foldable
  41
  42 : next-save ( n -- i ) cell - ;
  43
  44 : xt-save ( n -- i ) 2 cells - ;
  45
  46 M: ppc stack-frame ( n -- i )
  47     local@ factor-area-size + 4 cells align ;
  48
  49 M: temp-reg v>operand drop 11 ;
  50
  51 M: int-regs return-reg drop 3 ;
  52 M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
  53 M: int-regs vregs
  54     drop {
  55         3 4 5 6 7 8 9 10
  56         16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
  57     } ;
  58
  59 M: float-regs return-reg drop 1 ;
  60 M: float-regs param-regs
  61     drop os H{
  62         { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
  63         { linux { 1 2 3 4 5 6 7 8 } }
  64     } at ;
  65 M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
  66
  67 GENERIC: loc>operand ( loc -- reg n )
  68
  69 M: ds-loc loc>operand n>> cells neg ds-reg swap ;
  70 M: rs-loc loc>operand n>> cells neg rs-reg swap ;
  71
  72 M: immediate load-literal
  73     [ v>operand ] bi@ LOAD ;
  74
  75 M: ppc load-indirect ( obj reg -- )
  76     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
  77     dup 0 LWZ ;
  78
  79 M: ppc %save-word-xt ( -- )
  80     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
  81
  82 M: ppc %prologue ( n -- )
  83     0 MFLR
  84     1 1 pick neg ADDI
  85     11 1 pick xt-save STW
  86     dup 11 LI
  87     11 1 pick next-save STW
  88     0 1 rot lr-save + STW ;
  89
  90 M: ppc %epilogue ( n -- )
  91     #! At the end of each word that calls a subroutine, we store
  92     #! the previous link register value in r0 by popping it off
  93     #! the stack, set the link register to the contents of r0,
  94     #! and jump to the link register.
  95     0 1 pick lr-save + LWZ
  96     1 1 rot ADDI
  97     0 MTLR ;
  98
  99 : (%call) ( -- ) 11 MTLR BLRL ;
 100
 101 : (%jump) ( -- ) 11 MTCTR BCTR ;
 102
 103 : %load-dlsym ( symbol dll register -- )
 104     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 105
 106 M: ppc %call ( label -- ) BL ;
 107
 108 M: ppc %jump-label ( label -- ) B ;
 109
 110 M: ppc %jump-f ( label -- )
 111     0 "flag" operand f v>operand CMPI BEQ ;
 112
 113 M: ppc %dispatch ( -- )
 114     [
 115         %epilogue-later
 116         0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
 117         "offset" operand "n" operand 1 SRAWI
 118         11 11 "offset" operand ADD
 119         11 dup 6 cells LWZ
 120         (%jump)
 121     ] H{
 122         { +input+ { { f "n" } } }
 123         { +scratch+ { { f "offset" } } }
 124     } with-template ;
 125
 126 M: ppc %dispatch-label ( word -- )
 127     0 , rc-absolute-cell rel-word ;
 128
 129 M: ppc %return ( -- ) %epilogue-later BLR ;
 130
 131 M: ppc %unwind drop %return ;
 132
 133 M: ppc %peek ( vreg loc -- )
 134     >r v>operand r> loc>operand LWZ ;
 135
 136 M: ppc %replace
 137     >r v>operand r> loc>operand STW ;
 138
 139 M: ppc %unbox-float ( dst src -- )
 140     [ v>operand ] bi@ float-offset LFD ;
 141
 142 M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
 143
 144 M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
 145
 146 M: int-regs %save-param-reg drop 1 rot local@ STW ;
 147
 148 M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
 149
 150 GENERIC: STF ( src dst off reg-class -- )
 151
 152 M: single-float-regs STF drop STFS ;
 153
 154 M: double-float-regs STF drop STFD ;
 155
 156 M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
 157
 158 GENERIC: LF ( dst src off reg-class -- )
 159
 160 M: single-float-regs LF drop LFS ;
 161
 162 M: double-float-regs LF drop LFD ;
 163
 164 M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
 165
 166 M: stack-params %load-param-reg ( stack reg reg-class -- )
 167     drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
 168
 169 M: stack-params %save-param-reg ( stack reg reg-class -- )
 170     #! Funky. Read the parameter from the caller's stack frame.
 171     #! This word is used in callbacks
 172     drop
 173     0 1 rot param@ stack-frame* + LWZ
 174     0 1 rot local@ STW ;
 175
 176 M: ppc %prepare-unbox ( -- )
 177     ! First parameter is top of stack
 178     3 ds-reg 0 LWZ
 179     ds-reg dup cell SUBI ;
 180
 181 M: ppc %unbox ( n reg-class func -- )
 182     ! Value must be in r3
 183     ! Call the unboxer
 184     f %alien-invoke
 185     ! Store the return value on the C stack
 186     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 187
 188 M: ppc %unbox-long-long ( n func -- )
 189     ! Value must be in r3:r4
 190     ! Call the unboxer
 191     f %alien-invoke
 192     ! Store the return value on the C stack
 193     [
 194         3 1 pick local@ STW
 195         4 1 rot cell + local@ STW
 196     ] when* ;
 197
 198 M: ppc %unbox-large-struct ( n c-type -- )
 199     ! Value must be in r3
 200     ! Compute destination address
 201     4 1 roll local@ ADDI
 202     ! Load struct size
 203     heap-size 5 LI
 204     ! Call the function
 205     "to_value_struct" f %alien-invoke ;
 206
 207 M: ppc %box ( n reg-class func -- )
 208     ! If the source is a stack location, load it into freg #0.
 209     ! If the source is f, then we assume the value is already in
 210     ! freg #0.
 211     >r
 212     over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
 213     r> f %alien-invoke ;
 214
 215 M: ppc %box-long-long ( n func -- )
 216     >r [
 217         3 1 pick local@ LWZ
 218         4 1 rot cell + local@ LWZ
 219     ] when* r> f %alien-invoke ;
 220
 221 : temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
 222
 223 : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
 224
 225 M: ppc %prepare-box-struct ( size -- )
 226     #! Compute target address for value struct return
 227     3 1 rot f struct-return@ ADDI
 228     3 1 0 local@ STW ;
 229
 230 M: ppc %box-large-struct ( n c-type -- )
 231     #! If n = f, then we're boxing a returned struct
 232     heap-size
 233     [ swap struct-return@ ] keep
 234     ! Compute destination address
 235     3 1 roll ADDI
 236     ! Load struct size
 237     4 LI
 238     ! Call the function
 239     "box_value_struct" f %alien-invoke ;
 240
 241 M: ppc %prepare-alien-invoke
 242     #! Save Factor stack pointers in case the C code calls a
 243     #! callback which does a GC, which must reliably trace
 244     #! all roots.
 245     "stack_chain" f 11 %load-dlsym
 246     11 11 0 LWZ
 247     1 11 0 STW
 248     ds-reg 11 8 STW
 249     rs-reg 11 12 STW ;
 250
 251 M: ppc %alien-invoke ( symbol dll -- )
 252     11 %load-dlsym (%call) ;
 253
 254 M: ppc %alien-callback ( quot -- )
 255     3 load-indirect "c_to_factor" f %alien-invoke ;
 256
 257 M: ppc %prepare-alien-indirect ( -- )
 258     "unbox_alien" f %alien-invoke
 259     3 1 cell temp@ STW ;
 260
 261 M: ppc %alien-indirect ( -- )
 262     11 1 cell temp@ LWZ (%call) ;
 263
 264 M: ppc %callback-value ( ctype -- )
 265      ! Save top of data stack
 266      3 ds-reg 0 LWZ
 267      3 1 0 local@ STW
 268      ! Restore data/call/retain stacks
 269      "unnest_stacks" f %alien-invoke
 270      ! Restore top of data stack
 271      3 1 0 local@ LWZ
 272      ! Unbox former top of data stack to return registers
 273      unbox-return ;
 274
 275 M: ppc %cleanup ( alien-node -- ) drop ;
 276
 277 : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
 278
 279 : %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
 280
 281 : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
 282
 283 M: ppc value-structs?
 284     #! On Linux/PPC, value structs are passed in the same way
 285     #! as reference structs, we just have to make a copy first.
 286     os linux? not ;
 287
 288 M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
 289
 290 M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 291
 292 M: ppc struct-small-enough? ( size -- ? ) drop f ;
 293
 294 M: ppc %box-small-struct
 295     drop "No small structs" throw ;
 296
 297 M: ppc %unbox-small-struct
 298     drop "No small structs" throw ;
 299
 300 ! Alien intrinsics
 301 M: ppc %unbox-byte-array ( dst src -- )
 302     [ v>operand ] bi@ byte-array-offset ADDI ;
 303
 304 M: ppc %unbox-alien ( dst src -- )
 305     [ v>operand ] bi@ alien-offset LWZ ;
 306
 307 M: ppc %unbox-f ( dst src -- )
 308     drop 0 swap v>operand LI ;
 309
 310 M: ppc %unbox-any-c-ptr ( dst src -- )
 311     { "is-byte-array" "end" "start" } [ define-label ] each
 312     ! Address is computed in R12
 313     0 12 LI
 314     ! Load object into R11
 315     11 swap v>operand MR
 316     ! We come back here with displaced aliens
 317     "start" resolve-label
 318     ! Is the object f?
 319     0 11 f v>operand CMPI
 320     ! If so, done
 321     "end" get BEQ
 322     ! Is the object an alien?
 323     0 11 header-offset LWZ
 324     0 0 alien type-number tag-fixnum CMPI
 325     "is-byte-array" get BNE
 326     ! If so, load the offset
 327     0 11 alien-offset LWZ
 328     ! Add it to address being computed
 329     12 12 0 ADD
 330     ! Now recurse on the underlying alien
 331     11 11 underlying-alien-offset LWZ
 332     "start" get B
 333     "is-byte-array" resolve-label
 334     ! Add byte array address to address being computed
 335     12 12 11 ADD
 336     ! Add an offset to start of byte array's data area
 337     12 12 byte-array-offset ADDI
 338     "end" resolve-label
 339     ! Done, store address in destination register
 340     v>operand 12 MR ;