ppc-xlate.pl 9.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325
  1. #! /usr/bin/env perl
  2. # Copyright 2006-2016 The OpenSSL Project Authors. All Rights Reserved.
  3. #
  4. # Licensed under the OpenSSL license (the "License"). You may not use
  5. # this file except in compliance with the License. You can obtain a copy
  6. # in the file LICENSE in the source distribution or at
  7. # https://www.openssl.org/source/license.html
  8. my $flavour = shift;
  9. my $output = shift;
  10. open STDOUT,">$output" || die "can't open $output: $!";
  11. my %GLOBALS;
  12. my %TYPES;
  13. my $dotinlocallabels=($flavour=~/linux/)?1:0;
  14. ################################################################
  15. # directives which need special treatment on different platforms
  16. ################################################################
  17. my $type = sub {
  18. my ($dir,$name,$type) = @_;
  19. $TYPES{$name} = $type;
  20. if ($flavour =~ /linux/) {
  21. $name =~ s|^\.||;
  22. ".type $name,$type";
  23. } else {
  24. "";
  25. }
  26. };
  27. my $globl = sub {
  28. my $junk = shift;
  29. my $name = shift;
  30. my $global = \$GLOBALS{$name};
  31. my $type = \$TYPES{$name};
  32. my $ret;
  33. $name =~ s|^\.||;
  34. SWITCH: for ($flavour) {
  35. /aix/ && do { if (!$$type) {
  36. $$type = "\@function";
  37. }
  38. if ($$type =~ /function/) {
  39. $name = ".$name";
  40. }
  41. last;
  42. };
  43. /osx/ && do { $name = "_$name";
  44. last;
  45. };
  46. /linux.*(32|64le)/
  47. && do { $ret .= ".globl $name";
  48. if (!$$type) {
  49. $ret .= "\n.type $name,\@function";
  50. $$type = "\@function";
  51. }
  52. last;
  53. };
  54. /linux.*64/ && do { $ret .= ".globl $name";
  55. if (!$$type) {
  56. $ret .= "\n.type $name,\@function";
  57. $$type = "\@function";
  58. }
  59. if ($$type =~ /function/) {
  60. $ret .= "\n.section \".opd\",\"aw\"";
  61. $ret .= "\n.align 3";
  62. $ret .= "\n$name:";
  63. $ret .= "\n.quad .$name,.TOC.\@tocbase,0";
  64. $ret .= "\n.previous";
  65. $name = ".$name";
  66. }
  67. last;
  68. };
  69. }
  70. $ret = ".globl $name" if (!$ret);
  71. $$global = $name;
  72. $ret;
  73. };
  74. my $text = sub {
  75. my $ret = ($flavour =~ /aix/) ? ".csect\t.text[PR],7" : ".text";
  76. $ret = ".abiversion 2\n".$ret if ($flavour =~ /linux.*64le/);
  77. $ret;
  78. };
  79. my $machine = sub {
  80. my $junk = shift;
  81. my $arch = shift;
  82. if ($flavour =~ /osx/)
  83. { $arch =~ s/\"//g;
  84. $arch = ($flavour=~/64/) ? "ppc970-64" : "ppc970" if ($arch eq "any");
  85. }
  86. ".machine $arch";
  87. };
  88. my $size = sub {
  89. if ($flavour =~ /linux/)
  90. { shift;
  91. my $name = shift;
  92. my $real = $GLOBALS{$name} ? \$GLOBALS{$name} : \$name;
  93. my $ret = ".size $$real,.-$$real";
  94. $name =~ s|^\.||;
  95. if ($$real ne $name) {
  96. $ret .= "\n.size $name,.-$$real";
  97. }
  98. $ret;
  99. }
  100. else
  101. { ""; }
  102. };
  103. my $asciz = sub {
  104. shift;
  105. my $line = join(",",@_);
  106. if ($line =~ /^"(.*)"$/)
  107. { ".byte " . join(",",unpack("C*",$1),0) . "\n.align 2"; }
  108. else
  109. { ""; }
  110. };
  111. my $quad = sub {
  112. shift;
  113. my @ret;
  114. my ($hi,$lo);
  115. for (@_) {
  116. if (/^0x([0-9a-f]*?)([0-9a-f]{1,8})$/io)
  117. { $hi=$1?"0x$1":"0"; $lo="0x$2"; }
  118. elsif (/^([0-9]+)$/o)
  119. { $hi=$1>>32; $lo=$1&0xffffffff; } # error-prone with 32-bit perl
  120. else
  121. { $hi=undef; $lo=$_; }
  122. if (defined($hi))
  123. { push(@ret,$flavour=~/le$/o?".long\t$lo,$hi":".long\t$hi,$lo"); }
  124. else
  125. { push(@ret,".quad $lo"); }
  126. }
  127. join("\n",@ret);
  128. };
  129. ################################################################
  130. # simplified mnemonics not handled by at least one assembler
  131. ################################################################
  132. my $cmplw = sub {
  133. my $f = shift;
  134. my $cr = 0; $cr = shift if ($#_>1);
  135. # Some out-of-date 32-bit GNU assembler just can't handle cmplw...
  136. ($flavour =~ /linux.*32/) ?
  137. " .long ".sprintf "0x%x",31<<26|$cr<<23|$_[0]<<16|$_[1]<<11|64 :
  138. " cmplw ".join(',',$cr,@_);
  139. };
  140. my $bdnz = sub {
  141. my $f = shift;
  142. my $bo = $f=~/[\+\-]/ ? 16+9 : 16; # optional "to be taken" hint
  143. " bc $bo,0,".shift;
  144. } if ($flavour!~/linux/);
  145. my $bltlr = sub {
  146. my $f = shift;
  147. my $bo = $f=~/\-/ ? 12+2 : 12; # optional "not to be taken" hint
  148. ($flavour =~ /linux/) ? # GNU as doesn't allow most recent hints
  149. " .long ".sprintf "0x%x",19<<26|$bo<<21|16<<1 :
  150. " bclr $bo,0";
  151. };
  152. my $bnelr = sub {
  153. my $f = shift;
  154. my $bo = $f=~/\-/ ? 4+2 : 4; # optional "not to be taken" hint
  155. ($flavour =~ /linux/) ? # GNU as doesn't allow most recent hints
  156. " .long ".sprintf "0x%x",19<<26|$bo<<21|2<<16|16<<1 :
  157. " bclr $bo,2";
  158. };
  159. my $beqlr = sub {
  160. my $f = shift;
  161. my $bo = $f=~/-/ ? 12+2 : 12; # optional "not to be taken" hint
  162. ($flavour =~ /linux/) ? # GNU as doesn't allow most recent hints
  163. " .long ".sprintf "0x%X",19<<26|$bo<<21|2<<16|16<<1 :
  164. " bclr $bo,2";
  165. };
  166. # GNU assembler can't handle extrdi rA,rS,16,48, or when sum of last two
  167. # arguments is 64, with "operand out of range" error.
  168. my $extrdi = sub {
  169. my ($f,$ra,$rs,$n,$b) = @_;
  170. $b = ($b+$n)&63; $n = 64-$n;
  171. " rldicl $ra,$rs,$b,$n";
  172. };
  173. my $vmr = sub {
  174. my ($f,$vx,$vy) = @_;
  175. " vor $vx,$vy,$vy";
  176. };
  177. # Some ABIs specify vrsave, special-purpose register #256, as reserved
  178. # for system use.
  179. my $no_vrsave = ($flavour =~ /aix|linux64le/);
  180. my $mtspr = sub {
  181. my ($f,$idx,$ra) = @_;
  182. if ($idx == 256 && $no_vrsave) {
  183. " or $ra,$ra,$ra";
  184. } else {
  185. " mtspr $idx,$ra";
  186. }
  187. };
  188. my $mfspr = sub {
  189. my ($f,$rd,$idx) = @_;
  190. if ($idx == 256 && $no_vrsave) {
  191. " li $rd,-1";
  192. } else {
  193. " mfspr $rd,$idx";
  194. }
  195. };
  196. # PowerISA 2.06 stuff
  197. sub vsxmem_op {
  198. my ($f, $vrt, $ra, $rb, $op) = @_;
  199. " .long ".sprintf "0x%X",(31<<26)|($vrt<<21)|($ra<<16)|($rb<<11)|($op*2+1);
  200. }
  201. # made-up unaligned memory reference AltiVec/VMX instructions
  202. my $lvx_u = sub { vsxmem_op(@_, 844); }; # lxvd2x
  203. my $stvx_u = sub { vsxmem_op(@_, 972); }; # stxvd2x
  204. my $lvdx_u = sub { vsxmem_op(@_, 588); }; # lxsdx
  205. my $stvdx_u = sub { vsxmem_op(@_, 716); }; # stxsdx
  206. my $lvx_4w = sub { vsxmem_op(@_, 780); }; # lxvw4x
  207. my $stvx_4w = sub { vsxmem_op(@_, 908); }; # stxvw4x
  208. my $lvx_splt = sub { vsxmem_op(@_, 332); }; # lxvdsx
  209. my $vpermdi = sub { # xxpermdi
  210. my ($f, $vrt, $vra, $vrb, $dm) = @_;
  211. $dm = oct($dm) if ($dm =~ /^0/);
  212. " .long ".sprintf "0x%X",(60<<26)|($vrt<<21)|($vra<<16)|($vrb<<11)|($dm<<8)|(10<<3)|7;
  213. };
  214. # PowerISA 2.07 stuff
  215. sub vcrypto_op {
  216. my ($f, $vrt, $vra, $vrb, $op) = @_;
  217. " .long ".sprintf "0x%X",(4<<26)|($vrt<<21)|($vra<<16)|($vrb<<11)|$op;
  218. }
  219. my $vcipher = sub { vcrypto_op(@_, 1288); };
  220. my $vcipherlast = sub { vcrypto_op(@_, 1289); };
  221. my $vncipher = sub { vcrypto_op(@_, 1352); };
  222. my $vncipherlast= sub { vcrypto_op(@_, 1353); };
  223. my $vsbox = sub { vcrypto_op(@_, 0, 1480); };
  224. my $vshasigmad = sub { my ($st,$six)=splice(@_,-2); vcrypto_op(@_, $st<<4|$six, 1730); };
  225. my $vshasigmaw = sub { my ($st,$six)=splice(@_,-2); vcrypto_op(@_, $st<<4|$six, 1666); };
  226. my $vpmsumb = sub { vcrypto_op(@_, 1032); };
  227. my $vpmsumd = sub { vcrypto_op(@_, 1224); };
  228. my $vpmsubh = sub { vcrypto_op(@_, 1096); };
  229. my $vpmsumw = sub { vcrypto_op(@_, 1160); };
  230. # These are not really crypto, but one can use vcrypto_op
  231. my $vaddudm = sub { vcrypto_op(@_, 192); };
  232. my $vadduqm = sub { vcrypto_op(@_, 256); };
  233. my $vmuleuw = sub { vcrypto_op(@_, 648); };
  234. my $vmulouw = sub { vcrypto_op(@_, 136); };
  235. my $vrld = sub { vcrypto_op(@_, 196); };
  236. my $vsld = sub { vcrypto_op(@_, 1476); };
  237. my $vsrd = sub { vcrypto_op(@_, 1732); };
  238. my $mtsle = sub {
  239. my ($f, $arg) = @_;
  240. " .long ".sprintf "0x%X",(31<<26)|($arg<<21)|(147*2);
  241. };
  242. # PowerISA 3.0 stuff
  243. my $maddhdu = sub {
  244. my ($f, $rt, $ra, $rb, $rc) = @_;
  245. " .long ".sprintf "0x%X",(4<<26)|($rt<<21)|($ra<<16)|($rb<<11)|($rc<<6)|49;
  246. };
  247. my $maddld = sub {
  248. my ($f, $rt, $ra, $rb, $rc) = @_;
  249. " .long ".sprintf "0x%X",(4<<26)|($rt<<21)|($ra<<16)|($rb<<11)|($rc<<6)|51;
  250. };
  251. my $darn = sub {
  252. my ($f, $rt, $l) = @_;
  253. " .long ".sprintf "0x%X",(31<<26)|($rt<<21)|($l<<16)|(755<<1);
  254. };
  255. my $iseleq = sub {
  256. my ($f, $rt, $ra, $rb) = @_;
  257. " .long ".sprintf "0x%X",(31<<26)|($rt<<21)|($ra<<16)|($rb<<11)|(2<<6)|30;
  258. };
  259. # PowerISA 3.0B stuff
  260. my $addex = sub {
  261. my ($f, $rt, $ra, $rb, $cy) = @_; # only cy==0 is specified in 3.0B
  262. " .long ".sprintf "0x%X",(31<<26)|($rt<<21)|($ra<<16)|($rb<<11)|($cy<<9)|(170<<1);
  263. };
  264. my $vmsumudm = sub {
  265. my ($f, $vrt, $vra, $vrb, $vrc) = @_;
  266. " .long ".sprintf "0x%X",(4<<26)|($vrt<<21)|($vra<<16)|($vrb<<11)|($vrc<<6)|35;
  267. };
  268. while($line=<>) {
  269. $line =~ s|[#!;].*$||; # get rid of asm-style comments...
  270. $line =~ s|/\*.*\*/||; # ... and C-style comments...
  271. $line =~ s|^\s+||; # ... and skip white spaces in beginning...
  272. $line =~ s|\s+$||; # ... and at the end
  273. {
  274. $line =~ s|\.L(\w+)|L$1|g; # common denominator for Locallabel
  275. $line =~ s|\bL(\w+)|\.L$1|g if ($dotinlocallabels);
  276. }
  277. {
  278. $line =~ s|(^[\.\w]+)\:\s*||;
  279. my $label = $1;
  280. if ($label) {
  281. my $xlated = ($GLOBALS{$label} or $label);
  282. print "$xlated:";
  283. if ($flavour =~ /linux.*64le/) {
  284. if ($TYPES{$label} =~ /function/) {
  285. printf "\n.localentry %s,0\n",$xlated;
  286. }
  287. }
  288. }
  289. }
  290. {
  291. $line =~ s|^\s*(\.?)(\w+)([\.\+\-]?)\s*||;
  292. my $c = $1; $c = "\t" if ($c eq "");
  293. my $mnemonic = $2;
  294. my $f = $3;
  295. my $opcode = eval("\$$mnemonic");
  296. $line =~ s/\b(c?[rf]|v|vs)([0-9]+)\b/$2/g if ($c ne "." and $flavour !~ /osx/);
  297. if (ref($opcode) eq 'CODE') { $line = &$opcode($f,split(/,\s*/,$line)); }
  298. elsif ($mnemonic) { $line = $c.$mnemonic.$f."\t".$line; }
  299. }
  300. print $line if ($line);
  301. print "\n";
  302. }
  303. close STDOUT;