/unmaintained/ppc/ppc.factor

http://github.com/abeaumont/factor · Factor · 826 lines · 605 code · 166 blank · 55 comment · 43 complexity · 2630b4589e14bac291fc3678ff270e92 MD5 · raw file

  1. ! Copyright (C) 2005, 2010 Slava Pestov.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors assocs sequences kernel combinators
  4. classes.algebra byte-arrays make math math.order math.ranges
  5. system namespaces locals layouts words alien alien.accessors
  6. alien.c-types alien.complex alien.data alien.libraries
  7. literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
  8. compiler.cfg.registers compiler.cfg.instructions
  9. compiler.cfg.comparisons compiler.codegen.fixup
  10. compiler.cfg.intrinsics compiler.cfg.stack-frame
  11. compiler.cfg.build-stack-frame compiler.units compiler.constants
  12. compiler.codegen vm ;
  13. QUALIFIED-WITH: alien.c-types c
  14. FROM: cpu.ppc.assembler => B ;
  15. FROM: layouts => cell ;
  16. FROM: math => float ;
  17. IN: cpu.ppc
  18. ! PowerPC register assignments:
  19. ! r2-r12: integer vregs
  20. ! r13: data stack
  21. ! r14: retain stack
  22. ! r15: VM pointer
  23. ! r16-r29: integer vregs
  24. ! r30: integer scratch
  25. ! f0-f29: float vregs
  26. ! f30: float scratch
  27. ! Add some methods to the assembler that are useful to us
  28. M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
  29. M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
  30. enable-float-intrinsics
  31. M: ppc machine-registers
  32. {
  33. { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
  34. { float-regs $[ 0 29 [a,b] ] }
  35. } ;
  36. CONSTANT: scratch-reg 30
  37. CONSTANT: fp-scratch-reg 30
  38. M: ppc complex-addressing? f ;
  39. M: ppc fused-unboxing? f ;
  40. M: ppc %load-immediate ( reg n -- ) swap LOAD ;
  41. M: ppc %load-reference ( reg obj -- )
  42. [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
  43. [ \ f type-number swap LI ]
  44. if* ;
  45. M: ppc %alien-global ( register symbol dll -- )
  46. [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
  47. CONSTANT: ds-reg 13
  48. CONSTANT: rs-reg 14
  49. CONSTANT: vm-reg 15
  50. : %load-vm-addr ( reg -- ) vm-reg MR ;
  51. M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
  52. M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
  53. GENERIC: loc-reg ( loc -- reg )
  54. M: ds-loc loc-reg drop ds-reg ;
  55. M: rs-loc loc-reg drop rs-reg ;
  56. : loc>operand ( loc -- reg n )
  57. [ loc-reg ] [ n>> cells neg ] bi ; inline
  58. M: ppc %peek loc>operand LWZ ;
  59. M: ppc %replace loc>operand STW ;
  60. :: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
  61. M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
  62. M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
  63. HOOK: reserved-area-size os ( -- n )
  64. ! The start of the stack frame contains the size of this frame
  65. ! as well as the currently executing code block
  66. : factor-area-size ( -- n ) 2 cells ; foldable
  67. : next-save ( n -- i ) cell - ; foldable
  68. : xt-save ( n -- i ) 2 cells - ; foldable
  69. ! Next, we have the spill area as well as the FFI parameter area.
  70. ! It is safe for them to overlap, since basic blocks with FFI calls
  71. ! will never spill -- indeed, basic blocks with FFI calls do not
  72. ! use vregs at all, and the FFI call is a stack analysis sync point.
  73. ! In the future this will change and the stack frame logic will
  74. ! need to be untangled somewhat.
  75. : param@ ( n -- x ) reserved-area-size + ; inline
  76. : param-save-size ( -- n ) 8 cells ; foldable
  77. : local@ ( n -- x )
  78. reserved-area-size param-save-size + + ; inline
  79. : spill@ ( n -- offset )
  80. spill-offset local@ ;
  81. ! Some FP intrinsics need a temporary scratch area in the stack
  82. ! frame, 8 bytes in size. This is in the param-save area so it
  83. ! does not overlap with spill slots.
  84. : scratch@ ( n -- offset )
  85. factor-area-size + ;
  86. ! Finally we have the linkage area
  87. HOOK: lr-save os ( -- n )
  88. M: ppc stack-frame-size ( stack-frame -- i )
  89. (stack-frame-size)
  90. param-save-size +
  91. reserved-area-size +
  92. factor-area-size +
  93. 4 cells align ;
  94. M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
  95. M: ppc %jump ( word -- )
  96. 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
  97. 0 B rc-relative-ppc-3 rel-word-pic-tail ;
  98. M: ppc %jump-label ( label -- ) B ;
  99. M: ppc %return ( -- ) BLR ;
  100. M:: ppc %dispatch ( src temp -- )
  101. 0 temp LOAD32
  102. 3 cells rc-absolute-ppc-2/2 rel-here
  103. temp temp src LWZX
  104. temp MTCTR
  105. BCTR ;
  106. : (%slot) ( dst obj slot scale tag -- obj dst slot )
  107. [ 0 assert= ] bi@ swapd ;
  108. M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
  109. M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
  110. M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
  111. M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
  112. M: ppc %add ADD ;
  113. M: ppc %add-imm ADDI ;
  114. M: ppc %sub swap SUBF ;
  115. M: ppc %sub-imm SUBI ;
  116. M: ppc %mul MULLW ;
  117. M: ppc %mul-imm MULLI ;
  118. M: ppc %and AND ;
  119. M: ppc %and-imm ANDI ;
  120. M: ppc %or OR ;
  121. M: ppc %or-imm ORI ;
  122. M: ppc %xor XOR ;
  123. M: ppc %xor-imm XORI ;
  124. M: ppc %shl SLW ;
  125. M: ppc %shl-imm swapd SLWI ;
  126. M: ppc %shr SRW ;
  127. M: ppc %shr-imm swapd SRWI ;
  128. M: ppc %sar SRAW ;
  129. M: ppc %sar-imm SRAWI ;
  130. M: ppc %not NOT ;
  131. M: ppc %neg NEG ;
  132. :: overflow-template ( label dst src1 src2 cc insn -- )
  133. 0 0 LI
  134. 0 MTXER
  135. dst src2 src1 insn call
  136. cc {
  137. { cc-o [ label BO ] }
  138. { cc/o [ label BNO ] }
  139. } case ; inline
  140. M: ppc %fixnum-add ( label dst src1 src2 cc -- )
  141. [ ADDO. ] overflow-template ;
  142. M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
  143. [ SUBFO. ] overflow-template ;
  144. M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
  145. [ MULLWO. ] overflow-template ;
  146. M: ppc %add-float FADD ;
  147. M: ppc %sub-float FSUB ;
  148. M: ppc %mul-float FMUL ;
  149. M: ppc %div-float FDIV ;
  150. M: ppc integer-float-needs-stack-frame? t ;
  151. M:: ppc %integer>float ( dst src -- )
  152. HEX: 4330 scratch-reg LIS
  153. scratch-reg 1 0 scratch@ STW
  154. scratch-reg src MR
  155. scratch-reg dup HEX: 8000 XORIS
  156. scratch-reg 1 4 scratch@ STW
  157. dst 1 0 scratch@ LFD
  158. scratch-reg 4503601774854144.0 %load-reference
  159. fp-scratch-reg scratch-reg float-offset LFD
  160. dst dst fp-scratch-reg FSUB ;
  161. M:: ppc %float>integer ( dst src -- )
  162. fp-scratch-reg src FCTIWZ
  163. fp-scratch-reg 1 0 scratch@ STFD
  164. dst 1 4 scratch@ LWZ ;
  165. M: ppc %copy ( dst src rep -- )
  166. 2over eq? [ 3drop ] [
  167. {
  168. { tagged-rep [ MR ] }
  169. { int-rep [ MR ] }
  170. { double-rep [ FMR ] }
  171. } case
  172. ] if ;
  173. GENERIC: float-function-param* ( dst src -- )
  174. M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
  175. M: integer float-function-param* FMR ;
  176. : float-function-param ( i src -- )
  177. [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
  178. : float-function-return ( reg -- )
  179. float-regs return-regs at first double-rep %copy ;
  180. M:: ppc %unary-float-function ( dst src func -- )
  181. 0 src float-function-param
  182. func f %c-invoke
  183. dst float-function-return ;
  184. M:: ppc %binary-float-function ( dst src1 src2 func -- )
  185. 0 src1 float-function-param
  186. 1 src2 float-function-param
  187. func f %c-invoke
  188. dst float-function-return ;
  189. ! Internal format is always double-precision on PowerPC
  190. M: ppc %single>double-float double-rep %copy ;
  191. M: ppc %double>single-float FRSP ;
  192. M: ppc %unbox-alien ( dst src -- )
  193. alien-offset LWZ ;
  194. M:: ppc %unbox-any-c-ptr ( dst src -- )
  195. [
  196. "end" define-label
  197. 0 dst LI
  198. ! Is the object f?
  199. 0 src \ f type-number CMPI
  200. "end" get BEQ
  201. ! Compute tag in dst register
  202. dst src tag-mask get ANDI
  203. ! Is the object an alien?
  204. 0 dst alien type-number CMPI
  205. ! Add an offset to start of byte array's data
  206. dst src byte-array-offset ADDI
  207. "end" get BNE
  208. ! If so, load the offset and add it to the address
  209. dst src alien-offset LWZ
  210. "end" resolve-label
  211. ] with-scope ;
  212. : alien@ ( n -- n' ) cells alien type-number - ;
  213. M:: ppc %box-alien ( dst src temp -- )
  214. [
  215. "f" define-label
  216. dst \ f type-number %load-immediate
  217. 0 src 0 CMPI
  218. "f" get BEQ
  219. dst 5 cells alien temp %allot
  220. temp \ f type-number %load-immediate
  221. temp dst 1 alien@ STW
  222. temp dst 2 alien@ STW
  223. src dst 3 alien@ STW
  224. src dst 4 alien@ STW
  225. "f" resolve-label
  226. ] with-scope ;
  227. :: %box-displaced-alien/f ( dst displacement base -- )
  228. base dst 1 alien@ STW
  229. displacement dst 3 alien@ STW
  230. displacement dst 4 alien@ STW ;
  231. :: %box-displaced-alien/alien ( dst displacement base temp -- )
  232. ! Set new alien's base to base.base
  233. temp base 1 alien@ LWZ
  234. temp dst 1 alien@ STW
  235. ! Compute displacement
  236. temp base 3 alien@ LWZ
  237. temp temp displacement ADD
  238. temp dst 3 alien@ STW
  239. ! Compute address
  240. temp base 4 alien@ LWZ
  241. temp temp displacement ADD
  242. temp dst 4 alien@ STW ;
  243. :: %box-displaced-alien/byte-array ( dst displacement base temp -- )
  244. base dst 1 alien@ STW
  245. displacement dst 3 alien@ STW
  246. temp base byte-array-offset ADDI
  247. temp temp displacement ADD
  248. temp dst 4 alien@ STW ;
  249. :: %box-displaced-alien/dynamic ( dst displacement base temp -- )
  250. "not-f" define-label
  251. "not-alien" define-label
  252. ! Is base f?
  253. 0 base \ f type-number CMPI
  254. "not-f" get BNE
  255. ! Yes, it is f. Fill in new object
  256. dst displacement base %box-displaced-alien/f
  257. "end" get B
  258. "not-f" resolve-label
  259. ! Check base type
  260. temp base tag-mask get ANDI
  261. ! Is base an alien?
  262. 0 temp alien type-number CMPI
  263. "not-alien" get BNE
  264. dst displacement base temp %box-displaced-alien/alien
  265. ! We are done
  266. "end" get B
  267. ! Is base a byte array? It has to be, by now...
  268. "not-alien" resolve-label
  269. dst displacement base temp %box-displaced-alien/byte-array ;
  270. M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
  271. ! This is ridiculous
  272. [
  273. "end" define-label
  274. ! If displacement is zero, return the base
  275. dst base MR
  276. 0 displacement 0 CMPI
  277. "end" get BEQ
  278. ! Displacement is non-zero, we're going to be allocating a new
  279. ! object
  280. dst 5 cells alien temp %allot
  281. ! Set expired to f
  282. temp \ f type-number %load-immediate
  283. temp dst 2 alien@ STW
  284. dst displacement base temp
  285. {
  286. { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
  287. { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
  288. { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
  289. [ %box-displaced-alien/dynamic ]
  290. } cond
  291. "end" resolve-label
  292. ] with-scope ;
  293. : (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
  294. [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
  295. M: ppc %load-memory-imm ( dst base offset rep c-type -- )
  296. [
  297. {
  298. { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
  299. { c:uchar [ LBZ ] }
  300. { c:short [ LHA ] }
  301. { c:ushort [ LHZ ] }
  302. { c:int [ LWZ ] }
  303. { c:uint [ LWZ ] }
  304. } case
  305. ] [
  306. {
  307. { int-rep [ LWZ ] }
  308. { float-rep [ LFS ] }
  309. { double-rep [ LFD ] }
  310. } case
  311. ] ?if ;
  312. M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
  313. (%memory) [
  314. {
  315. { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
  316. { c:uchar [ LBZX ] }
  317. { c:short [ LHAX ] }
  318. { c:ushort [ LHZX ] }
  319. { c:int [ LWZX ] }
  320. { c:uint [ LWZX ] }
  321. } case
  322. ] [
  323. {
  324. { int-rep [ LWZX ] }
  325. { float-rep [ LFSX ] }
  326. { double-rep [ LFDX ] }
  327. } case
  328. ] ?if ;
  329. M: ppc %store-memory-imm ( src base offset rep c-type -- )
  330. [
  331. {
  332. { c:char [ STB ] }
  333. { c:uchar [ STB ] }
  334. { c:short [ STH ] }
  335. { c:ushort [ STH ] }
  336. { c:int [ STW ] }
  337. { c:uint [ STW ] }
  338. } case
  339. ] [
  340. {
  341. { int-rep [ STW ] }
  342. { float-rep [ STFS ] }
  343. { double-rep [ STFD ] }
  344. } case
  345. ] ?if ;
  346. M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
  347. (%memory) [
  348. {
  349. { c:char [ STBX ] }
  350. { c:uchar [ STBX ] }
  351. { c:short [ STHX ] }
  352. { c:ushort [ STHX ] }
  353. { c:int [ STWX ] }
  354. { c:uint [ STWX ] }
  355. } case
  356. ] [
  357. {
  358. { int-rep [ STWX ] }
  359. { float-rep [ STFSX ] }
  360. { double-rep [ STFDX ] }
  361. } case
  362. ] ?if ;
  363. : load-zone-ptr ( reg -- )
  364. vm-reg "nursery" vm-field-offset ADDI ;
  365. : load-allot-ptr ( nursery-ptr allot-ptr -- )
  366. [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
  367. :: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
  368. scratch-reg allot-ptr n data-alignment get align ADDI
  369. scratch-reg nursery-ptr 0 STW ;
  370. :: store-header ( dst class -- )
  371. class type-number tag-header scratch-reg LI
  372. scratch-reg dst 0 STW ;
  373. : store-tagged ( dst tag -- )
  374. dupd type-number ORI ;
  375. M:: ppc %allot ( dst size class nursery-ptr -- )
  376. nursery-ptr dst load-allot-ptr
  377. nursery-ptr dst size inc-allot-ptr
  378. dst class store-header
  379. dst class store-tagged ;
  380. : load-cards-offset ( dst -- )
  381. 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
  382. : load-decks-offset ( dst -- )
  383. 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
  384. :: (%write-barrier) ( temp1 temp2 -- )
  385. card-mark scratch-reg LI
  386. ! Mark the card
  387. temp1 temp1 card-bits SRWI
  388. temp2 load-cards-offset
  389. temp1 scratch-reg temp2 STBX
  390. ! Mark the card deck
  391. temp1 temp1 deck-bits card-bits - SRWI
  392. temp2 load-decks-offset
  393. temp1 scratch-reg temp2 STBX ;
  394. M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
  395. scale 0 assert= tag 0 assert=
  396. temp1 src slot ADD
  397. temp1 temp2 (%write-barrier) ;
  398. M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
  399. temp1 src slot tag slot-offset ADDI
  400. temp1 temp2 (%write-barrier) ;
  401. M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
  402. temp1 vm-reg "nursery" vm-field-offset LWZ
  403. temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
  404. temp1 temp1 size ADDI
  405. ! is here >= end?
  406. temp1 0 temp2 CMP
  407. cc {
  408. { cc<= [ label BLE ] }
  409. { cc/<= [ label BGT ] }
  410. } case ;
  411. : gc-root-offsets ( seq -- seq' )
  412. [ n>> spill@ ] map f like ;
  413. M: ppc %call-gc ( gc-roots -- )
  414. 3 swap gc-root-offsets %load-reference
  415. 4 %load-vm-addr
  416. "inline_gc" f %c-invoke ;
  417. M: ppc %prologue ( n -- )
  418. 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
  419. 0 MFLR
  420. {
  421. [ [ 1 1 ] dip neg ADDI ]
  422. [ [ 11 1 ] dip xt-save STW ]
  423. [ 11 LI ]
  424. [ [ 11 1 ] dip next-save STW ]
  425. [ [ 0 1 ] dip lr-save + STW ]
  426. } cleave ;
  427. M: ppc %epilogue ( n -- )
  428. #! At the end of each word that calls a subroutine, we store
  429. #! the previous link register value in r0 by popping it off
  430. #! the stack, set the link register to the contents of r0,
  431. #! and jump to the link register.
  432. [ [ 0 1 ] dip lr-save + LWZ ]
  433. [ [ 1 1 ] dip ADDI ] bi
  434. 0 MTLR ;
  435. :: (%boolean) ( dst temp branch1 branch2 -- )
  436. "end" define-label
  437. dst \ f type-number %load-immediate
  438. "end" get branch1 execute( label -- )
  439. branch2 [ "end" get branch2 execute( label -- ) ] when
  440. dst \ t %load-reference
  441. "end" get resolve-label ; inline
  442. :: %boolean ( dst cc temp -- )
  443. cc negate-cc order-cc {
  444. { cc< [ dst temp \ BLT f (%boolean) ] }
  445. { cc<= [ dst temp \ BLE f (%boolean) ] }
  446. { cc> [ dst temp \ BGT f (%boolean) ] }
  447. { cc>= [ dst temp \ BGE f (%boolean) ] }
  448. { cc= [ dst temp \ BEQ f (%boolean) ] }
  449. { cc/= [ dst temp \ BNE f (%boolean) ] }
  450. } case ;
  451. : (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
  452. : (%compare-integer-imm) ( src1 src2 -- )
  453. [ 0 ] 2dip CMPI ; inline
  454. : (%compare-imm) ( src1 src2 -- )
  455. [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
  456. : (%compare-float-unordered) ( src1 src2 -- )
  457. [ 0 ] dip FCMPU ; inline
  458. : (%compare-float-ordered) ( src1 src2 -- )
  459. [ 0 ] dip FCMPO ; inline
  460. :: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
  461. cc {
  462. { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
  463. { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
  464. { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
  465. { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
  466. { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
  467. { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
  468. { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
  469. { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
  470. { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
  471. { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
  472. { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
  473. { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
  474. { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
  475. { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
  476. } case ; inline
  477. M: ppc %compare [ (%compare) ] 2dip %boolean ;
  478. M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
  479. M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
  480. M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
  481. src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
  482. dst temp branch1 branch2 (%boolean) ;
  483. M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
  484. src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
  485. dst temp branch1 branch2 (%boolean) ;
  486. :: %branch ( label cc -- )
  487. cc order-cc {
  488. { cc< [ label BLT ] }
  489. { cc<= [ label BLE ] }
  490. { cc> [ label BGT ] }
  491. { cc>= [ label BGE ] }
  492. { cc= [ label BEQ ] }
  493. { cc/= [ label BNE ] }
  494. } case ;
  495. M:: ppc %compare-branch ( label src1 src2 cc -- )
  496. src1 src2 (%compare)
  497. label cc %branch ;
  498. M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
  499. src1 src2 (%compare-imm)
  500. label cc %branch ;
  501. M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
  502. src1 src2 (%compare-integer-imm)
  503. label cc %branch ;
  504. :: (%branch) ( label branch1 branch2 -- )
  505. label branch1 execute( label -- )
  506. branch2 [ label branch2 execute( label -- ) ] when ; inline
  507. M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
  508. src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
  509. label branch1 branch2 (%branch) ;
  510. M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
  511. src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
  512. label branch1 branch2 (%branch) ;
  513. : load-from-frame ( dst n rep -- )
  514. {
  515. { int-rep [ [ 1 ] dip LWZ ] }
  516. { tagged-rep [ [ 1 ] dip LWZ ] }
  517. { float-rep [ [ 1 ] dip LFS ] }
  518. { double-rep [ [ 1 ] dip LFD ] }
  519. { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
  520. } case ;
  521. : next-param@ ( n -- reg x )
  522. [ 17 ] dip param@ ;
  523. : store-to-frame ( src n rep -- )
  524. {
  525. { int-rep [ [ 1 ] dip STW ] }
  526. { tagged-rep [ [ 1 ] dip STW ] }
  527. { float-rep [ [ 1 ] dip STFS ] }
  528. { double-rep [ [ 1 ] dip STFD ] }
  529. { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
  530. } case ;
  531. M: ppc %spill ( src rep dst -- )
  532. swap [ n>> spill@ ] dip store-to-frame ;
  533. M: ppc %reload ( dst rep src -- )
  534. swap [ n>> spill@ ] dip load-from-frame ;
  535. M: ppc %loop-entry ;
  536. M: ppc return-regs
  537. {
  538. { int-regs { 3 4 5 6 } }
  539. { float-regs { 1 } }
  540. } ;
  541. M:: ppc %save-param-reg ( stack reg rep -- )
  542. reg stack local@ rep store-to-frame ;
  543. M:: ppc %load-param-reg ( stack reg rep -- )
  544. reg stack local@ rep load-from-frame ;
  545. GENERIC: load-param ( reg src -- )
  546. M: integer load-param int-rep %copy ;
  547. M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
  548. GENERIC: store-param ( reg dst -- )
  549. M: integer store-param swap int-rep %copy ;
  550. M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
  551. :: call-unbox-func ( src func -- )
  552. 3 src load-param
  553. 4 %load-vm-addr
  554. func f %c-invoke ;
  555. M:: ppc %unbox ( src n rep func -- )
  556. src func call-unbox-func
  557. ! Store the return value on the C stack
  558. n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
  559. M:: ppc %unbox-long-long ( src n func -- )
  560. src func call-unbox-func
  561. ! Store the return value on the C stack
  562. n [
  563. 3 1 n local@ STW
  564. 4 1 n cell + local@ STW
  565. ] when ;
  566. M:: ppc %unbox-large-struct ( src n c-type -- )
  567. 4 src load-param
  568. 3 1 n local@ ADDI
  569. c-type heap-size 5 LI
  570. "memcpy" "libc" load-library %c-invoke ;
  571. M:: ppc %box ( dst n rep func -- )
  572. n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
  573. rep double-rep? 5 4 ? %load-vm-addr
  574. func f %c-invoke
  575. 3 dst store-param ;
  576. M:: ppc %box-long-long ( dst n func -- )
  577. n [
  578. 3 1 n local@ LWZ
  579. 4 1 n cell + local@ LWZ
  580. ] when
  581. 5 %load-vm-addr
  582. func f %c-invoke
  583. 3 dst store-param ;
  584. : struct-return@ ( n -- n )
  585. [ stack-frame get params>> ] unless* local@ ;
  586. M: ppc %prepare-box-struct ( -- )
  587. #! Compute target address for value struct return
  588. 3 1 f struct-return@ ADDI
  589. 3 1 0 local@ STW ;
  590. M:: ppc %box-large-struct ( dst n c-type -- )
  591. ! If n = f, then we're boxing a returned struct
  592. ! Compute destination address and load struct size
  593. 3 1 n struct-return@ ADDI
  594. c-type heap-size 4 LI
  595. 5 %load-vm-addr
  596. ! Call the function
  597. "from_value_struct" f %c-invoke
  598. 3 dst store-param ;
  599. M:: ppc %restore-context ( temp1 temp2 -- )
  600. temp1 %context
  601. ds-reg temp1 "datastack" context-field-offset LWZ
  602. rs-reg temp1 "retainstack" context-field-offset LWZ ;
  603. M:: ppc %save-context ( temp1 temp2 -- )
  604. temp1 %context
  605. 1 temp1 "callstack-top" context-field-offset STW
  606. ds-reg temp1 "datastack" context-field-offset STW
  607. rs-reg temp1 "retainstack" context-field-offset STW ;
  608. M: ppc %c-invoke ( symbol dll -- )
  609. [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
  610. M: ppc %alien-indirect ( src -- )
  611. [ 11 ] dip load-param 11 MTLR BLRL ;
  612. M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
  613. M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
  614. M: ppc immediate-store? drop f ;
  615. M: ppc return-struct-in-registers? ( c-type -- ? )
  616. c-type return-in-registers?>> ;
  617. M:: ppc %box-small-struct ( dst c-type -- )
  618. #! Box a <= 16-byte struct returned in r3:r4:r5:r6
  619. c-type heap-size 7 LI
  620. 8 %load-vm-addr
  621. "from_medium_struct" f %c-invoke
  622. 3 dst store-param ;
  623. : %unbox-struct-1 ( -- )
  624. ! Alien must be in r3.
  625. 3 3 0 LWZ ;
  626. : %unbox-struct-2 ( -- )
  627. ! Alien must be in r3.
  628. 4 3 4 LWZ
  629. 3 3 0 LWZ ;
  630. : %unbox-struct-4 ( -- )
  631. ! Alien must be in r3.
  632. 6 3 12 LWZ
  633. 5 3 8 LWZ
  634. 4 3 4 LWZ
  635. 3 3 0 LWZ ;
  636. M:: ppc %unbox-small-struct ( src c-type -- )
  637. src 3 load-param
  638. c-type heap-size {
  639. { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
  640. { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
  641. { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
  642. } cond ;
  643. M: ppc %begin-callback ( -- )
  644. 3 %load-vm-addr
  645. "begin_callback" f %c-invoke ;
  646. M: ppc %alien-callback ( quot -- )
  647. 3 swap %load-reference
  648. 4 3 quot-entry-point-offset LWZ
  649. 4 MTLR
  650. BLRL ;
  651. M: ppc %end-callback ( -- )
  652. 3 %load-vm-addr
  653. "end_callback" f %c-invoke ;
  654. enable-float-functions
  655. USE: vocabs.loader
  656. {
  657. { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
  658. { [ os linux? ] [ "cpu.ppc.linux" require ] }
  659. } cond
  660. complex-double c-type t >>return-in-registers? drop