#! /usr/bin/env perl
# Copyright 2007-2020 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the Apache License 2.0 (the "License").  You may not use
# this file except in compliance with the License.  You can obtain a copy
# in the file LICENSE in the source distribution or at
# https://www.openssl.org/source/license.html


# ====================================================================
# Written by Andy Polyakov <appro@openssl.org> for the OpenSSL
# project. The module is, however, dual licensed under OpenSSL and
# CRYPTOGAMS licenses depending on where you obtain it. For further
# details see http://www.openssl.org/~appro/cryptogams/.
# ====================================================================

# SHA1 block procedure for s390x.

# April 2007.
#
# Performance is >30% better than gcc 3.3 generated code. But the real
# twist is that SHA1 hardware support is detected and utilized. In
# which case performance can reach further >4.5x for larger chunks.

# January 2009.
#
# Optimize Xupdate for amount of memory references and reschedule
# instructions to favour dual-issue z10 pipeline. On z10 hardware is
# "only" ~2.3x faster than software.

# November 2010.
#
# Adapt for -m31 build. If kernel supports what's called "highgprs"
# feature on Linux [see /proc/cpuinfo], it's possible to use 64-bit
# instructions and achieve "64-bit" performance even in 31-bit legacy
# application context. The feature is not specific to any particular
# processor, as long as it's "z-CPU". Latter implies that the code
# remains z/Architecture specific. On z990 it was measured to perform
# 23% better than code generated by gcc 4.3.

$kimdfunc=1;	# magic function code for kimd instruction

# $output is the last argument if it looks like a file (it has an extension)
# $flavour is the first argument if it doesn't look like a file
$output = $#ARGV >= 0 && $ARGV[$#ARGV] =~ m|\.\w+$| ? pop : undef;
$flavour = $#ARGV >= 0 && $ARGV[0] !~ m|\.| ? shift : undef;

if ($flavour =~ /3[12]/) {
	$SIZE_T=4;
	$g="";
} else {
	$SIZE_T=8;
	$g="g";
}

$output and open STDOUT,">$output";

$K_00_39="%r0"; $K=$K_00_39;
$K_40_79="%r1";
$ctx="%r2";	$prefetch="%r2";
$inp="%r3";
$len="%r4";

$A="%r5";
$B="%r6";
$C="%r7";
$D="%r8";
$E="%r9";	@V=($A,$B,$C,$D,$E);
$t0="%r10";
$t1="%r11";
@X=("%r12","%r13","%r14");
$sp="%r15";

$stdframe=16*$SIZE_T+4*8;
$frame=$stdframe+16*4;

sub Xupdate {
my $i=shift;

$code.=<<___ if ($i==15);
	lg	$prefetch,$stdframe($sp)	### Xupdate(16) warm-up
	lr	$X[0],$X[2]
___
return if ($i&1);	# Xupdate is vectorized and executed every 2nd cycle
$code.=<<___ if ($i<16);
	lg	$X[0],`$i*4`($inp)	### Xload($i)
	rllg	$X[1],$X[0],32
___
$code.=<<___ if ($i>=16);
	xgr	$X[0],$prefetch		### Xupdate($i)
	lg	$prefetch,`$stdframe+4*(($i+2)%16)`($sp)
	xg	$X[0],`$stdframe+4*(($i+8)%16)`($sp)
	xgr	$X[0],$prefetch
	rll	$X[0],$X[0],1
	rllg	$X[1],$X[0],32
	rll	$X[1],$X[1],1
	rllg	$X[0],$X[1],32
	lr	$X[2],$X[1]		# feedback
___
$code.=<<___ if ($i<=70);
	stg	$X[0],`$stdframe+4*($i%16)`($sp)
___
unshift(@X,pop(@X));
}

sub BODY_00_19 {
my ($i,$a,$b,$c,$d,$e)=@_;
my $xi=$X[1];

	&Xupdate($i);
$code.=<<___;
	alr	$e,$K		### $i
	rll	$t1,$a,5
	lr	$t0,$d
	xr	$t0,$c
	alr	$e,$t1
	nr	$t0,$b
	alr	$e,$xi
	xr	$t0,$d
	rll	$b,$b,30
	alr	$e,$t0
___
}

sub BODY_20_39 {
my ($i,$a,$b,$c,$d,$e)=@_;
my $xi=$X[1];

	&Xupdate($i);
$code.=<<___;
	alr	$e,$K		### $i
	rll	$t1,$a,5
	lr	$t0,$b
	alr	$e,$t1
	xr	$t0,$c
	alr	$e,$xi
	xr	$t0,$d
	rll	$b,$b,30
	alr	$e,$t0
___
}

sub BODY_40_59 {
my ($i,$a,$b,$c,$d,$e)=@_;
my $xi=$X[1];

	&Xupdate($i);
$code.=<<___;
	alr	$e,$K		### $i
	rll	$t1,$a,5
	lr	$t0,$b
	alr	$e,$t1
	or	$t0,$c
	lr	$t1,$b
	nr	$t0,$d
	nr	$t1,$c
	alr	$e,$xi
	or	$t0,$t1
	rll	$b,$b,30
	alr	$e,$t0
___
}

$code.=<<___;
#include "s390x_arch.h"

.text
.align	64
.type	Ktable,\@object
Ktable: .long	0x5a827999,0x6ed9eba1,0x8f1bbcdc,0xca62c1d6
	.skip	48	#.long	0,0,0,0,0,0,0,0,0,0,0,0
.size	Ktable,.-Ktable
.globl	sha1_block_data_order
.type	sha1_block_data_order,\@function
sha1_block_data_order:
___
$code.=<<___ if ($kimdfunc);
	larl	%r1,OPENSSL_s390xcap_P
	lg	%r0,S390X_KIMD(%r1)	# check kimd capabilities
	tmhh	%r0,`0x8000>>$kimdfunc`
	jz	.Lsoftware
	lghi	%r0,$kimdfunc
	lgr	%r1,$ctx
	lgr	%r2,$inp
	sllg	%r3,$len,6
	.long	0xb93e0002	# kimd %r0,%r2
	brc	1,.-4		# pay attention to "partial completion"
	br	%r14
.align	16
.Lsoftware:
___
$code.=<<___;
	lghi	%r1,-$frame
	st${g}	$ctx,`2*$SIZE_T`($sp)
	stm${g}	%r6,%r15,`6*$SIZE_T`($sp)
	lgr	%r0,$sp
	la	$sp,0(%r1,$sp)
	st${g}	%r0,0($sp)

	larl	$t0,Ktable
	llgf	$A,0($ctx)
	llgf	$B,4($ctx)
	llgf	$C,8($ctx)
	llgf	$D,12($ctx)
	llgf	$E,16($ctx)

	lg	$K_00_39,0($t0)
	lg	$K_40_79,8($t0)

.Lloop:
	rllg	$K_00_39,$K_00_39,32
___
for ($i=0;$i<20;$i++)	{ &BODY_00_19($i,@V); unshift(@V,pop(@V)); }
$code.=<<___;
	rllg	$K_00_39,$K_00_39,32
___
for (;$i<40;$i++)	{ &BODY_20_39($i,@V); unshift(@V,pop(@V)); }
$code.=<<___;	$K=$K_40_79;
	rllg	$K_40_79,$K_40_79,32
___
for (;$i<60;$i++)	{ &BODY_40_59($i,@V); unshift(@V,pop(@V)); }
$code.=<<___;
	rllg	$K_40_79,$K_40_79,32
___
for (;$i<80;$i++)	{ &BODY_20_39($i,@V); unshift(@V,pop(@V)); }
$code.=<<___;

	l${g}	$ctx,`$frame+2*$SIZE_T`($sp)
	la	$inp,64($inp)
	al	$A,0($ctx)
	al	$B,4($ctx)
	al	$C,8($ctx)
	al	$D,12($ctx)
	al	$E,16($ctx)
	st	$A,0($ctx)
	st	$B,4($ctx)
	st	$C,8($ctx)
	st	$D,12($ctx)
	st	$E,16($ctx)
	brct${g} $len,.Lloop

	lm${g}	%r6,%r15,`$frame+6*$SIZE_T`($sp)
	br	%r14
.size	sha1_block_data_order,.-sha1_block_data_order
.string	"SHA1 block transform for s390x, CRYPTOGAMS by <appro\@openssl.org>"
___

$code =~ s/\`([^\`]*)\`/eval $1/gem;

print $code;
close STDOUT or die "error closing STDOUT: $!";