unmaintained/arm/architecture/architecture.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types arrays cpu.arm.assembler compiler
   4 kernel kernel.private math namespaces words words.private
   5 generator.registers generator.fixup generator cpu.architecture
   6 system layouts ;
   7 IN: cpu.arm.architecture
   8
   9 TUPLE: arm-backend ;
  10
  11 ! ARM register assignments:
  12 ! R0-R4, R7-R10 integer vregs
  13 ! R11, R12 temporary
  14 ! R5 data stack
  15 ! R6 retain stack
  16 ! R7 primitives
  17
  18 : ds-reg R5 ; inline
  19 : rs-reg R6 ; inline
  20
  21 M: temp-reg v>operand drop R12 ;
  22
  23 M: int-regs return-reg drop R0 ;
  24 M: int-regs param-regs drop { R0 R1 R2 R3 } ;
  25 M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ;
  26
  27 ! No FPU support yet
  28 M: float-regs param-regs drop { } ;
  29 M: float-regs vregs drop { } ;
  30
  31 : <+/-> dup 0 < [ neg <-> ] [ <+> ] if ;
  32
  33 GENERIC: loc>operand ( loc -- reg addressing )
  34 M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap <+/-> ;
  35 M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ;
  36
  37 : load-cell ( reg -- )
  38     [
  39         "end" define-label
  40         ! Load target address
  41         PC 0 <+> LDR
  42         ! Skip an instruction
  43         "end" get B
  44         ! The target address
  45         0 ,
  46         ! Continue here
  47         "end" resolve-label
  48     ] with-scope ;
  49
  50 : call-cell ( -- )
  51     ! Compute return address; we skip 3 instructions
  52     LR PC 8 ADD
  53     ! Load target address
  54     R12 PC 0 <+> LDR
  55     ! Jump to target address
  56     R12 BX
  57     ! The target address
  58     0 , ;
  59
  60 M: arm-backend load-indirect ( obj reg -- )
  61     tuck load-cell rc-absolute-cell rel-literal
  62     dup 0 <+> LDR ;
  63
  64 M: immediate load-literal
  65     over v>operand small-enough? [
  66         [ v>operand ] bi@ swap MOV
  67     ] [
  68         v>operand load-indirect
  69     ] if ;
  70
  71 : lr-save ( n -- i ) cell - ;
  72 : next-save ( n -- i ) 2 cells - ;
  73 : xt-save ( n -- i ) 3 cells - ;
  74 : factor-area-size 5 cells ;
  75
  76 M: arm-backend stack-frame ( n -- i )
  77     factor-area-size + 8 align ;
  78
  79 M: arm-backend %save-word-xt ( -- )
  80     R12 PC 9 cells SUB ;
  81
  82 M: arm-backend %save-dispatch-xt ( -- )
  83     R12 PC 2 cells SUB ;
  84
  85 M: arm-backend %prologue ( n -- )
  86     SP SP pick SUB
  87     R11 over MOV
  88     R11 SP pick next-save <+> STR
  89     R12 SP pick xt-save <+> STR
  90     LR SP rot lr-save <+> STR ;
  91
  92 M: arm-backend %epilogue ( n -- )
  93     LR SP pick lr-save <+> LDR
  94     SP SP rot ADD ;
  95
  96 : compile-dlsym ( symbol dll reg -- )
  97     load-cell rc-absolute rel-dlsym ;
  98
  99 : %alien-global ( symbol dll reg -- )
 100     [ compile-dlsym ] keep dup 0 <+> LDR ;
 101
 102 M: arm-backend %profiler-prologue ( -- )
 103     #! We can clobber R0 here since it is undefined at the start
 104     #! of a word.
 105     R12 load-indirect
 106     R0 R12 profile-count-offset <+> LDR
 107     R0 R0 1 v>operand ADD
 108     R0 R12 profile-count-offset <+> STR ;
 109
 110 M: arm-backend %call-label ( label -- ) BL ;
 111
 112 M: arm-backend %jump-label ( label -- ) B ;
 113
 114 : %prepare-primitive ( -- )
 115     #! Save stack pointer to stack_chain->callstack_top, load XT
 116     R1 SP 4 SUB ;
 117
 118 M: arm-backend %call-primitive ( word -- )
 119     %prepare-primitive
 120     call-cell rc-absolute-cell rel-word ;
 121
 122 M: arm-backend %jump-primitive ( word -- )
 123     %prepare-primitive
 124     ! Load target address
 125     R12 PC 0 <+> LDR
 126     ! Jump to target address
 127     R12 BX
 128     ! The target address
 129     0 , rc-absolute-cell rel-word ;
 130
 131 M: arm-backend %jump-t ( label -- )
 132     "flag" operand f v>operand CMP NE B ;
 133
 134 : (%dispatch) ( word-table# -- )
 135     #! Load jump table target address into reg.
 136     "scratch" operand PC "n" operand 1 <LSR> ADD
 137     "scratch" operand dup 0 <+> LDR
 138     rc-indirect-arm rel-dispatch
 139     "scratch" operand dup compiled-header-size ADD ;
 140
 141 M: arm-backend %call-dispatch ( word-table# -- )
 142     [
 143         (%dispatch)
 144         "scratch" operand BLX
 145     ] H{
 146         { +input+ { { f "n" } } }
 147         { +scratch+ { { f "scratch" } } }
 148     } with-template ;
 149
 150 M: arm-backend %jump-dispatch ( word-table# -- )
 151     [
 152         %epilogue-later
 153         (%dispatch)
 154         "scratch" operand BX
 155     ] H{
 156         { +input+ { { f "n" } } }
 157         { +scratch+ { { f "scratch" } } }
 158     } with-template ;
 159
 160 M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
 161
 162 M: arm-backend %unwind drop %return ;
 163
 164 M: arm-backend %peek >r v>operand r> loc>operand LDR ;
 165
 166 M: arm-backend %replace >r v>operand r> loc>operand STR ;
 167
 168 : (%inc) ( n reg -- )
 169     dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
 170
 171 M: arm-backend %inc-d ( n -- ) ds-reg (%inc) ;
 172
 173 M: arm-backend %inc-r ( n -- ) rs-reg (%inc) ;
 174
 175 : stack@ SP swap <+> ;
 176
 177 M: int-regs %save-param-reg drop swap stack@ STR ;
 178
 179 M: int-regs %load-param-reg drop swap stack@ LDR ;
 180
 181 M: stack-params %save-param-reg
 182     drop
 183     R12 swap stack-frame* + stack@ LDR
 184     R12 swap stack@ STR ;
 185
 186 M: stack-params %load-param-reg
 187     drop
 188     R12 rot stack@ LDR
 189     R12 swap stack@ STR ;
 190
 191 M: arm-backend %prepare-unbox ( -- )
 192     ! First parameter is top of stack
 193     R0 R5 4 <-!> LDR ;
 194
 195 M: arm-backend %unbox ( n reg-class func -- )
 196     ! Value must be in R0.
 197     ! Call the unboxer
 198     f %alien-invoke
 199     ! Store the return value on the C stack
 200     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 201
 202 M: arm-backend %unbox-long-long ( n func -- )
 203     ! Value must be in R0:R1.
 204     ! Call the unboxer
 205     f %alien-invoke
 206     ! Store the return value on the C stack
 207     [
 208         R0 over stack@ STR
 209         R1 swap cell + stack@ STR
 210     ] when* ;
 211
 212 M: arm-backend %unbox-small-struct ( size -- )
 213     #! Alien must be in R0.
 214     drop
 215     "alien_offset" f %alien-invoke
 216     ! Load first cell
 217     R0 R0 0 <+> LDR ;
 218
 219 M: arm-backend %unbox-large-struct ( n size -- )
 220     #! Alien must be in R0.
 221     ! Compute destination address
 222     R1 SP roll ADD
 223     R2 swap MOV
 224     ! Copy the struct to the stack
 225     "to_value_struct" f %alien-invoke ;
 226
 227 M: arm-backend %box ( n reg-class func -- )
 228     ! If the source is a stack location, load it into freg #0.
 229     ! If the source is f, then we assume the value is already in
 230     ! freg #0.
 231     >r
 232     over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
 233     r> f %alien-invoke ;
 234
 235 M: arm-backend %box-long-long ( n func -- )
 236     >r [
 237         R0 over stack@ LDR
 238         R1 swap cell + stack@ LDR
 239     ] when* r> f %alien-invoke ;
 240
 241 M: arm-backend %box-small-struct ( size -- )
 242     #! Box a 4-byte struct returned in R0.
 243     R2 swap MOV
 244     "box_small_struct" f %alien-invoke ;
 245
 246 : temp@ stack-frame* factor-area-size - swap - ;
 247
 248 : struct-return@ ( size n -- n )
 249     [
 250         stack-frame* +
 251     ] [
 252         stack-frame* factor-area-size - swap -
 253     ] ?if ;
 254
 255 M: arm-backend %prepare-box-struct ( size -- )
 256     ! Compute target address for value struct return
 257     R0 SP rot f struct-return@ ADD
 258     ! Store it as the first parameter
 259     R0 0 stack@ STR ;
 260
 261 M: arm-backend %box-large-struct ( n size -- )
 262     ! Compute destination address
 263     [ swap struct-return@ ] keep
 264     R0 SP roll ADD
 265     R1 swap MOV
 266     ! Copy the struct from the C stack
 267     "box_value_struct" f %alien-invoke ;
 268
 269 M: arm-backend struct-small-enough? ( size -- ? )
 270     wince? [ drop f ] [ 4 <= ] if ;
 271
 272 M: arm-backend %prepare-alien-invoke
 273     #! Save Factor stack pointers in case the C code calls a
 274     #! callback which does a GC, which must reliably trace
 275     #! all roots.
 276     "stack_chain" f R12 %alien-global
 277     SP R12 0 <+> STR
 278     ds-reg R12 8 <+> STR
 279     rs-reg R12 12 <+> STR ;
 280
 281 M: arm-backend %alien-invoke ( symbol dll -- )
 282     call-cell rc-absolute-cell rel-dlsym ;
 283
 284 M: arm-backend %prepare-alien-indirect ( -- )
 285     "unbox_alien" f %alien-invoke
 286     R0 SP cell temp@ <+> STR ;
 287
 288 M: arm-backend %alien-indirect ( -- )
 289     R12 SP cell temp@ <+> LDR
 290     R12 BLX ;
 291
 292 M: arm-backend %alien-callback ( quot -- )
 293     R0 load-indirect
 294     "c_to_factor" f %alien-invoke ;
 295
 296 M: arm-backend %callback-value ( ctype -- )
 297     ! Save top of data stack
 298     %prepare-unbox
 299     R0 SP cell temp@ <+> STR
 300     ! Restore data/call/retain stacks
 301     "unnest_stacks" f %alien-invoke
 302     ! Place former top of data stack in R0
 303     R0 SP cell temp@ <+> LDR
 304     ! Unbox R0
 305     unbox-return ;
 306
 307 M: arm-backend %cleanup ( alien-node -- ) drop ;
 308
 309 : %untag ( dest src -- ) BIN: 111 BIC ;
 310
 311 : %untag-fixnum ( dest src -- ) tag-bits get <ASR> MOV ;
 312
 313 : %tag-fixnum ( dest src -- ) tag-bits get <LSL> MOV ;
 314
 315 M: arm-backend value-structs? t ;
 316
 317 M: arm-backend small-enough? ( n -- ? ) 0 255 between? ;
 318
 319 M: long-long-type c-type-stack-align? drop wince? not ;
 320
 321 M: arm-backend fp-shadows-int? ( -- ? ) f ;
 322
 323 ! Alien intrinsics
 324 M: arm-backend %unbox-byte-array ( dst src -- )
 325     [ v>operand ] bi@ byte-array-offset ADD ;
 326
 327 M: arm-backend %unbox-alien ( dst src -- )
 328     [ v>operand ] bi@ alien-offset <+> LDR ;
 329
 330 M: arm-backend %unbox-f ( dst src -- )
 331     drop v>operand 0 MOV ;
 332
 333 M: arm-backend %unbox-any-c-ptr ( dst src -- )
 334     #! We need three registers here. R11 and R12 are reserved
 335     #! temporary registers. The third one is R14, which we have
 336     #! to save/restore.
 337     "end" define-label
 338     "start" define-label
 339     ! Save R14.
 340     R14 SP 4 <-> STR
 341     ! Address is computed in R11
 342     R11 0 MOV
 343     ! Load object into R12
 344     R12 swap v>operand MOV
 345     ! We come back here with displaced aliens
 346     "start" resolve-label
 347     ! Is the object f?
 348     R12 f v>operand CMP
 349     ! If so, done
 350     "end" get EQ B
 351     ! Is the object an alien?
 352     R14 R12 header-offset <+/-> LDR
 353     R14 alien type-number tag-fixnum CMP
 354     ! Add byte array address to address being computed
 355     R11 R11 R12 NE ADD
 356     ! Add an offset to start of byte array's data area
 357     R11 R11 byte-array-offset NE ADD
 358     "end" get NE B
 359     ! If alien, load the offset
 360     R14 R12 alien-offset <+/-> LDR
 361     ! Add it to address being computed
 362     R11 R11 R14 ADD
 363     ! Now recurse on the underlying alien
 364     R12 R12 underlying-alien-offset <+/-> LDR
 365     "start" get B
 366     "end" resolve-label
 367     ! Done, store address in destination register
 368     v>operand R11 MOV
 369     ! Restore R14.
 370     R14 SP 4 <-> LDR ;