basis/cpu/ppc/architecture/architecture.factor

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