#!/usr/bin/perl -I/home/phil/perl/cpan/DataTableText/lib/ -I. -I/home/phil/perl/cpan/AsmC/lib/ #------------------------------------------------------------------------------- # Generate X86 assembler code using Perl as a macro pre-processor. # Philip R Brenan at appaapps dot com, Appa Apps Ltd Inc., 2021 #------------------------------------------------------------------------------- # podDocumentation package Nasm::X86; our $VERSION = "20210728"; use warnings FATAL => qw(all); use strict; use Carp qw(confess cluck); use Data::Dump qw(dump); use Data::Table::Text qw(confirmHasCommandLineCommand convertUtf32ToUtf8 currentDirectory evalFile fff fileMd5Sum fileSize findFiles firstNChars formatTable fpe fpf genHash lll owf pad readFile stringsAreNotEqual stringMd5Sum temporaryFile); use Asm::C qw(:all); use feature qw(say current_sub); my %rodata; # Read only data already written my %rodatas; # Read only string already written my %subroutines; # Subroutines generated my @rodata; # Read only data my @data; # Data my @bss; # Block started by symbol my @text; # Code my @extern; # External symbols imports for linking with C libraries my @link; # Specify libraries which to link against in the final assembly stage my $interpreter = q(-I /usr/lib64/ld-linux-x86-64.so.2); # The ld command needs an interpreter if we are linking with C. my $develop = -e q(/home/phil/); # Developing our $stdin = 0; # File descriptor for standard input our $stdout = 1; # File descriptor for standard output our $stderr = 2; # File descriptor for standard error my %Registers; # The names of all the registers my %RegisterContaining; # The largest register containing a register BEGIN{ my %r = ( map {$_=>[ 8, '8' ]} qw(al bl cl dl r8b r9b r10b r11b r12b r13b r14b r15b r8l r9l r10l r11l r12l r13l r14l r15l sil dil spl bpl ah bh ch dh)); %r = (%r, map {$_=>[16, 's' ]} qw(cs ds es fs gs ss)); %r = (%r, map {$_=>[16, '16' ]} qw(ax bx cx dx r8w r9w r10w r11w r12w r13w r14w r15w si di sp bp)); %r = (%r, map {$_=>[32, '32a']} qw(eax ebx ecx edx esi edi esp ebp)); %r = (%r, map {$_=>[32, '32b']} qw(r8d r9d r10d r11d r12d r13d r14d r15d)); %r = (%r, map {$_=>[80, 'f' ]} qw(st0 st1 st2 st3 st4 st5 st6 st7)); %r = (%r, map {$_=>[64, '64' ]} qw(rax rbx rcx rdx r8 r9 r10 r11 r12 r13 r14 r15 rsi rdi rsp rbp rip rflags)); %r = (%r, map {$_=>[64, '64m']} qw(mm0 mm1 mm2 mm3 mm4 mm5 mm6 mm7)); %r = (%r, map {$_=>[128, '128']} qw(xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7 xmm8 xmm9 xmm10 xmm11 xmm12 xmm13 xmm14 xmm15 xmm16 xmm17 xmm18 xmm19 xmm20 xmm21 xmm22 xmm23 xmm24 xmm25 xmm26 xmm27 xmm28 xmm29 xmm30 xmm31)); %r = (%r, map {$_=>[256, '256']} qw(ymm0 ymm1 ymm2 ymm3 ymm4 ymm5 ymm6 ymm7 ymm8 ymm9 ymm10 ymm11 ymm12 ymm13 ymm14 ymm15 ymm16 ymm17 ymm18 ymm19 ymm20 ymm21 ymm22 ymm23 ymm24 ymm25 ymm26 ymm27 ymm28 ymm29 ymm30 ymm31)); %r = (%r, map {$_=>[512, '512']} qw(zmm0 zmm1 zmm2 zmm3 zmm4 zmm5 zmm6 zmm7 zmm8 zmm9 zmm10 zmm11 zmm12 zmm13 zmm14 zmm15 zmm16 zmm17 zmm18 zmm19 zmm20 zmm21 zmm22 zmm23 zmm24 zmm25 zmm26 zmm27 zmm28 zmm29 zmm30 zmm31)); %r = (%r, map {$_=>[64, 'm' ]} qw(k0 k1 k2 k3 k4 k5 k6 k7)); %Registers = %r; # Register names my sub registerContaining($@) {my ($r, @r) = @_; # Register, contents $RegisterContaining{$r} = $r; # A register contains itself $RegisterContaining{$_} = $r for @r; # Registers contained by a register } registerContaining("k$_") for 0..7; registerContaining("zmm$_", "ymm$_", "xmm$_") for 0..31; registerContaining("r${_}x", "e${_}x", "${_}x", "${_}l", "${_}h") for qw(a b c d); registerContaining("r${_}", "r${_}l", "r${_}w", "r${_}b", "r${_}d") for 8..15; registerContaining("r${_}p", "e${_}p", "${_}p", "${_}pl") for qw(s b); registerContaining("r${_}i", "e${_}i", "${_}i", "${_}il") for qw(s d); my @i0 = qw(popfq pushfq rdtsc ret syscall); # Zero operand instructions my @i1 = split /\s+/, <1} values %r; for my $v(sort keys %v) # Types of register {my @r = grep {$r{$_}[1] eq $v} sort keys %r; my $s = "sub registers_$v\{".dump(\@r)."}"; eval $s; confess "$s$@" if $@; } if (1) # Instructions that take zero operands {my $s = ''; for my $i(@i0) {my $I = ucfirst $i; $s .= < 8; } } sub SetMaskRegister($$$) # Set the mask register to ones starting at the specified position for the specified length and zeroes elsewhere {my ($mask, $start, $length) = @_; # Mask register to set, register containing start position or 0 for position 0, register containing end position @_ == 3 or confess; PushR my @save = (r15, r14); Mov r15, -1; if ($start) # Non zero start {Mov r14, $start; Bzhi r15, r15, r14; Not r15; Add r14, $length; } else # Starting at zero {Mov r14, $length; } Bzhi r15, r15, r14; Kmovq $mask, r15; PopR @save; } sub SetZF() # Set the zero flag {Cmp rax, rax; } sub ClearZF() # Clear the zero flag {PushR rax; Mov rax, 1; Cmp rax, 0; PopR rax; } #D2 Tracing # Trace the execution of a program my $Trace; # Tracing level: 0 - no tracing my $TraceCount; # Trace count my $TraceStop; # Report the position of this trace count sub Trace # Add tracing code {return unless $Trace; ++$TraceCount; &PrintString(3, "$TraceCount\n"); confess "Trace" if $TraceStop and $TraceStop == $TraceCount; } #D2 Tracking # Track the use of registers so that we do not accidently use unset registers or write into registers that are already in use. my %Keep; # Registers to keep my %KeepStack; # Registers keep stack across PushR and PopR sub Keep(@) # Mark registers as in use so that they cannot be updated until we explicitly free them. Complain if the register is already in use. {my (@target) = @_; # Registers to keep for my $target(@target) {my $r = $RegisterContaining{$target}; # Containing register $r or confess "No such register $target"; if (my $l = $Keep{$r}) # Check whether the register is already in use {say STDERR $l; confess "$r reset"; } eval {confess "$r set"}; $Keep{$r} = $@; } $target[0] # Return first register } sub KeepSet($) # Confirm that the specified registers are in use {my ($target) = @_; # Registers to keep my $r = $RegisterContaining{$target}; # Containing register confess "No such register: $target\n" unless $r; $Keep{$r} # Confirm that the register is already in use } sub KeepPush(@) # Push the current status of the specified registers and then mark them as free {my (@target) = @_; # Registers to keep for my $target(@target) {my $r = $RegisterContaining{$target}; # Containing register push $KeepStack{$r}->@*, $Keep{$r}; # Check whether the register is already in use } KeepFree @target; } # Mark them as free sub KeepPop(@) # Reset the status of the specified registers to the status quo ante the last push {my (@target) = @_; # Registers to keep for my $target(@target) {my $r = $RegisterContaining{$target}; # Containing register if (my $s = $KeepStack{$r}) # Stack for register {if (@$s) # Stack of previous statuses {$Keep{$r} = pop @$s; # Reload prior status } else # Stack empty {confess "Cannot restore $target as stack is empty"; } } else # Stack empty {confess "Cannot restore $target as never stacked"; } } } # Mark them as free sub KeepReturn(@) # Pop the specified register and mark it as in use to effect a subroutine return with this register. {my (@target) = @_; # Registers to return KeepPop @target; for my $target(@target) {Keep $target unless KeepSet $target; # Mark as use in use unless already in use at this level } } # Mark them as free sub KeepFree(@) # Free registers so that they can be reused {my (@target) = @_; # Registers to free for my $target(@target) {my $r = $RegisterContaining{$target}; # Containing register $r or confess "No such register: $target"; delete $Keep{$r}; } $target[0] # Return first register } #D2 Mask # Operations on mask registers sub LoadConstantIntoMaskRegister($$) # Load a constant into a mask register {my ($reg, $value) = @_; # Mask register to load, constant to load PushR rax; Mov rax, $value; # Load a general register Kmovq $reg, rax; # Load mask register PopR rax; } #D1 Structured Programming # Structured programming constructs sub If($$;$) # If {my ($jump, $then, $else) = @_; # Jump op code of variable, then - required , else - optional @_ >= 2 && @_ <= 3 or confess; ref($jump) or $jump =~ m(\AJ(e|g|ge|gt|h|l|le|ne|nz|z)\Z) or confess "Invalid jump: $jump"; if (ref($jump)) # Variable reference - non zero then then else else {PushR r15; Mov r15, $jump->address; Cmp r15,0; PopR r15; __SUB__->(q(Jz), $then, $else); } elsif (!$else) # No else {Comment "if then"; my $end = Label; push @text, < the name of the subroutine so it can be reused rather than regenerated, comment=> a comment describing the sub {my ($body, %options) = @_; # Body, options. @_ >= 1 or confess; my $name = $options{name} // [caller(1)]->[3]; # Optional name for subroutine reuse if ($name and !$options{keepOut} and my $n = $subroutines{$name}) {return $n} # Return the label of a pre-existing copy of the code my $start = Label; my $end = Label; Jmp $end; SetLabel $start; &$body; Ret; SetLabel $end; $subroutines{$name} = $start if $name; # Cache a reference to the generated code if a name was supplied $start } sub Subroutine(&%) # Create a subroutine that can be called in assembler code {my ($body, %options) = @_; # Body, options. @_ >= 1 or confess; my $name = $options{name} // [caller(1)]->[3]; # Subroutine name my %in = ($options{in} // {})->%*; # Input parameters my %out = ($options{out} // {})->%*; # Output parameters my %io = ($options{io} // {})->%*; # Update u=in place parameters my $comment = $options{comment}; # Optional comment describing sub Comment "Subroutine " .($comment) if $comment; # Assemble comment if ($name and my $n = $subroutines{$name}) {return $n} # Return the label of a pre-existing copy of the code my $scope = &Scope; # Create a new scope my %p; my sub checkSize($$) # Check the size of a parameter {my ($name, $size) = @_; confess "Invalid size $size for parameter: $name" unless $size =~ m(\A(1|2|3|4|5|6)\Z); $p{$name} = Variable($size, $name); # Make a value parameter variable } my sub checkIo($$) # Check an io parameter {my ($name, $size) = @_; confess "Invalid size $size for parameter: $name" unless $size =~ m(\A(1|2|3|4|5|6)\Z); $p{$name} = Vr($name, $size); # Make a reference parameter variable } checkSize($_, $in {$_}) for keys %in; checkSize($_, $out{$_}) for keys %out; checkIo ($_, $io {$_}) for keys %io; my $start = Label; # Jump over code my $end = Label; Jmp $end; SetLabel $start; &$body({%p}); # Code with parameters Ret; SetLabel $end; &ScopeEnd; # End scope defined($name) or confess "Name missing"; $subroutines{$name} = genHash(__PACKAGE__."::Sub", # Subroutine definition start => $start, scope => $scope, name => $name, comment => $comment, in => {%in}, out => {%out}, io => {%io}, variables => {%p}, ); } sub Nasm::X86::Sub::call($%) # Call a sub passing it some parameters {my ($sub, @parameters) = @_; # Subroutine descriptor, parameter variables my %p; while(@parameters) # Copy parameters supplied by the caller {my $p = shift @parameters; # Check parameters provided by caller my $n = ref($p) ? $p->name : $p; defined($n) or confess "No name or variable"; my $v = ref($p) ? $p : shift @parameters; unless ($sub->in->{$n} or $sub->out->{$n} or $sub->io->{$n}) {my @t; push @t, map {[q(in), $_]} keys $sub->in ->%*; push @t, map {[q(io), $_]} keys $sub->io ->%*; push @t, map {[q(out), $_]} keys $sub->out->%*; my $t = formatTable([@t], [qw(Type Name)]); confess "Invalid parameter: '$n'\n$t"; } $p{$n} = $v; } for my $p(keys $sub->in->%*) # Load input parameters {confess "Missing in parameter: $p" unless my $v = $p{$p}; $sub->variables->{$p}->copy($v); } for my $p(keys $sub->io->%*) # Load io parameters {confess "Missing io parameter: $p" unless my $v = $p{$p}; $sub->variables->{$p}->copyAddress($v); } my $n = $$sub{name}; Trace; Call $$sub{start}; # Call the sub routine Trace; for my $p(keys $sub->out->%*) # Load output parameters {confess qq(Missing output parameter: "$p") unless my $v = $p{$p}; $v->copy($sub->variables->{$p}); } } sub cr(&@) # Call a subroutine with a reordering of the registers. {my ($body, @registers) = @_; # Code to execute with reordered registers, registers to reorder ReorderSyscallRegisters @registers; &$body; UnReorderSyscallRegisters @registers; } sub Comment(@) # Insert a comment into the assembly code {my (@comment) = @_; # Text of comment my $c = join "", @comment; my ($p, $f, $l) = caller; push @text, < qq(PrintNL$channel); } sub PrintErrNL() # Print a new line to stderr {@_ == 0 or confess; PrintNL($stderr); } sub PrintOutNL() # Print a new line to stderr {@_ == 0 or confess; PrintNL($stdout); } sub PrintString($@) # Print a constant string to the specified channel {my ($channel, @string) = @_; # Channel, Strings @_ >= 2 or confess; my $c = join ' ', @string; my $l = length($c); my $a = Rs($c); SaveFirstFour; Comment "Write to channel $channel, the string: ".dump($c); Mov rax, 1; Mov rdi, $channel; Mov rsi, $a; Mov rdx, $l; Syscall; RestoreFirstFour(); } sub PrintErrString(@) # Print a constant string to stderr. {my (@string) = @_; # String PrintString($stderr, @string); } sub PrintOutString(@) # Print a constant string to stdout. {my (@string) = @_; # String PrintString($stdout, @string); } sub PrintErrStringNL(@) # Print a constant string followed by a new line to stderr {my (@string) = @_; # Strings PrintErrString(@string); PrintErrNL; } sub PrintOutStringNL(@) # Print a constant string followed by a new line to stdout {my (@string) = @_; # Strings PrintOutString(@string); PrintOutNL; } sub hexTranslateTable #P Create/address a hex translate table and return its label {my $h = '0123456789ABCDEF'; my @t; for my $i(split //, $h) {for my $j(split //, $h) {push @t, "$i$j"; } } Rs @t # Constant strings are only saved if they are unique, else a read only copy is returned. } sub PrintRaxInHex($;$) # Write the content of register rax in hexadecimal in big endian notation to the specified channel {my ($channel, $end) = @_; # Channel, optional end byte @_ == 1 or @_ == 2 or confess; Comment "Print Rax In Hex on channel: $channel"; my $hexTranslateTable = hexTranslateTable; $end //= 7; # Default end byte my $sub = Macro {SaveFirstFour rax; # Rax is a parameter Mov rdx, rax; # Content to be printed Mov rdi, 2; # Length of a byte in hex KeepFree rax; for my $i((7-$end)..7) # Each byte {my $s = 8*$i; KeepFree rax; Mov rax, rdx; Shl rax, $s; # Push selected byte high Shr rax, 56; # Push select byte low Shl rax, 1; # Multiply by two because each entry in the translation table is two bytes long Lea rax, "[$hexTranslateTable+rax]"; PrintMemory($channel); # Print memory addressed by rax for length specified by rdi PrintString($channel, ' ') if $i % 2 and $i < 7; } RestoreFirstFour; } name => "PrintOutRaxInHexOn-$channel-$end"; Call $sub; } sub PrintErrRaxInHex() # Write the content of register rax in hexadecimal in big endian notation to stderr {@_ == 0 or confess; PrintRaxInHex($stderr); } sub PrintOutRaxInHex() # Write the content of register rax in hexadecimal in big endian notation to stderr {@_ == 0 or confess; PrintRaxInHex($stdout); } sub PrintOutRaxInReverseInHex # Write the content of register rax to stderr in hexadecimal in little endian notation {@_ == 0 or confess; Comment "Print Rax In Reverse In Hex"; Push rax; Bswap rax; PrintOutRaxInHex; Pop rax; } sub PrintRegisterInHex($@) # Print the named registers as hex strings {my ($channel, @r) = @_; # Channel to print on, names of the registers to print @_ >= 2 or confess; for my $r(@r) # Each register to print {Comment "Print register $r in Hex on channel: $channel"; Call Macro {PrintString($channel, sprintf("%6s: ", $r)); # Register name my sub printReg(@) # Print the contents of a register {my (@regs) = @_; # Size in bytes, work registers my $s = RegisterSize $r; # Size of the register PushR @regs; # Save work registers PushRR $r; # Place register contents on stack - might be a x|y|z - without tracking PopRR @regs; # Load work registers without tracking for my $i(keys @regs) # Print work registers to print input register {my $R = $regs[$i]; if ($R !~ m(\Arax)) {PrintString($channel, " "); # Separate blocks of bytes with a space Keep $R; KeepFree rax; Mov rax, $R } PrintRaxInHex($channel); # Print work register PrintString($channel, " ") unless $i == $#regs; } PopR @regs; # Balance the single push of what might be a large register }; if ($r =~ m(\A[kr])) {printReg qw(rax)} # 64 bit register requested elsif ($r =~ m(\Ax)) {printReg qw(rax rbx)} # xmm* elsif ($r =~ m(\Ay)) {printReg qw(rax rbx rcx rdx)} # ymm* elsif ($r =~ m(\Az)) {printReg qw(rax rbx rcx rdx r8 r9 r10 r11)} # zmm* PrintNL($channel); } name => "PrintOutRegister${r}InHexOn$channel"; # One routine per register printed } } sub PrintErrRegisterInHex(@) # Print the named registers as hex strings on stderr {my (@r) = @_; # Names of the registers to print PrintRegisterInHex $stderr, @r; } sub PrintOutRegisterInHex(@) # Print the named registers as hex strings on stdout {my (@r) = @_; # Names of the registers to print PrintRegisterInHex $stdout, @r; } sub PrintOutRipInHex #P Print the instruction pointer in hex {@_ == 0 or confess; my @regs = qw(rax); my $sub = Macro {PushR @regs; my $l = Label; push @text, < "PrintOutRipInHex"; Call $sub; } sub PrintOutRflagsInHex #P Print the flags register in hex {@_ == 0 or confess; my @regs = qw(rax); my $sub = Macro {PushR @regs; Pushfq; Pop rax; PrintOutString "rfl: "; PrintOutRaxInHex; PrintOutNL; PopR @regs; } name=> "PrintOutRflagsInHex"; Call $sub; } sub PrintOutRegistersInHex # Print the general purpose registers in hex {@_ == 0 or confess; my $sub = Macro {PrintOutRipInHex; PrintOutRflagsInHex; my @regs = qw(rax); PushR @regs; my $w = registers_64(); for my $r(sort @$w) {next if $r =~ m(rip|rflags); if ($r eq rax) {Pop rax; Push rax } PrintOutString reverse(pad(reverse($r), 3)).": "; Keep $r unless KeepSet $r ; KeepFree rax; Mov rax, $r; PrintOutRaxInHex; PrintOutNL; } PopR @regs; } name=> "PrintOutRegistersInHex"; Call $sub; } sub PrintErrZF # Print the zero flag without disturbing it on stderr {@_ == 0 or confess; Pushfq; IfNz {PrintErrStringNL "ZF=0"} sub {PrintErrStringNL "ZF=1"}; Popfq; } sub PrintOutZF # Print the zero flag without disturbing it on stdout {@_ == 0 or confess; Pushfq; IfNz {PrintOutStringNL "ZF=0"} sub {PrintOutStringNL "ZF=1"}; Popfq; } #D1 Variables # Variable definitions and operations #D2 Scopes # Each variable is contained in a scope in an effort to detect references to out of scope variables my $ScopeCurrent; # The current scope - being the last one created sub Scope(*) # Create and stack a new scope and continue with it as the current scope {my ($name) = @_; # Scope name my $N = $ScopeCurrent ? $ScopeCurrent->number+1 : 0; # Number of this scope my $s = genHash(__PACKAGE__."::Scope", # Scope definition name => $name, # Name of scope - usually the sub routine name number => $N, # Number of this scope depth => undef, # Lexical depth of scope parent => undef, # Parent scope ); if (my $c = $ScopeCurrent) {$s->parent = $c; $s->depth = $c->depth + 1; } else {$s->depth = 0; } $ScopeCurrent = $s; } sub ScopeEnd # End the current scope and continue with the containing parent scope {if (my $c = $ScopeCurrent) {$ScopeCurrent = $c->parent; } else {confess "No more scopes to finish"; } } sub Nasm::X86::Scope::contains($;$) # Check that the named parent scope contains the specified child scope. If no child scope is supplied we use the current scope to check that the parent scope is currently visible {my ($parent, $child) = @_; # Parent scope, child scope, for(my $c = $child//$ScopeCurrent; $c; $c = $c->parent) # Ascend scope tree looking for parent {return 1 if $c == $parent; # Found parent so child or current scope can see the parent } undef # Parent not found so child is not contained by the parent scope } sub Nasm::X86::Scope::currentlyVisible($) # Check that the named parent scope is currently visible {my ($scope) = @_; # Scope to check for visibility $scope->contains # Check that the named parent scope is currently visible } #D2 Definitions # Variable definitions sub Variable($$;$%) # Create a new variable with the specified size and name initialized via an expression {my ($size, $name, $expr, %options) = @_; # Size as a power of 2, name of variable, optional expression initializing variable, options $size =~ m(\A0|1|2|3|4|5|6|b|w|d|q|x|y|z\Z)i or confess "Size must be 0..6 or b|w|d|q|x|y|z";# Check size of variable my $const = $options{constant} // 0; # Whether the variable is in fact a constant if ($const) # Comment in appropriate section {defined($expr) or confess "Value required for constant"; defined($name) or confess "Name required"; RComment qq(Constant name: "$name", size: $size, value $expr); } else {DComment qq(Variable name: "$name", size: $size); } my $init = 0; # Initializer if (defined $expr) # Initialize value {if ($Registers{$expr}) {$const and confess "Cannot use a register to initialize a constant"; } # elsif (ref($expr)) {} # Reference a variable else {$init = $expr; } } else {$const and confess "Expression required for constant"; } my $label; # Allocate space $label = $size =~ m(\A0|b\Z) ? Db(0) : $size =~ m(\A1|w\Z) ? Dw(0) : $size =~ m(\A2|d\Z) ? Dd(0) : $size =~ m(\A3|q\Z) ? Dq(0) : $size =~ m(\A4|x\Z) ? Dq(0,0) : $size =~ m(\A5|y\Z) ? Dq(0,0,0,0) : $size =~ m(\A6|z\Z) ? Dq(0,0,0,0,0,0,0,0) : undef unless $const; $label = $size =~ m(\A0|b\Z) ? Rb($init) : $size =~ m(\A1|w\Z) ? Rw($init) : $size =~ m(\A2|d\Z) ? Rd($init) : $size =~ m(\A3|q\Z) ? Rq($init) : $size =~ m(\A4|x\Z) ? Rq(0,0) : $size =~ m(\A5|y\Z) ? Rq(0,0,0,0) : $size =~ m(\A6|z\Z) ? Rq(0,0,0,0,0,0,0,0) : undef if $const; my $nSize = $size =~ tr(bwdqxyz) (0123456)r; # Size of variable if (defined $expr) # Initialize variable if an initializer was supplied {my $t = "[$label]"; if ($Registers{$expr}) {$const and confess "Cannot use a register to initialize a constant"; Mov $t, $expr; } # elsif (ref($expr)) {} # Reference a variable elsif (!$const) {PushR r15; Mov r15, $expr; Mov $t, r15b if $nSize == 0; Mov $t, r15w if $nSize == 1; Mov $t, r15d if $nSize == 2; Mov $t, r15 if $nSize == 3; PopR r15; } } genHash(__PACKAGE__."::Variable", # Variable definition constant => $options{constant}, # Constant if true expr => $expr, # Expression that initializes the variable label => $label, # Address in memory laneSize => undef, # Size of the lanes in this variable name => $name, # Name of the variable purpose => undef, # Purpose of this variable # reference => ref($expr) ? $expr->size : undef, # Reference to another variable reference => undef, # Reference to another variable saturate => undef, # Computations should saturate rather then wrap if true signed => undef, # Elements of x|y|zmm registers are signed if true size => $nSize, # Size of variable ); } sub Vb(*;$%) # Define a byte variable {my ($name, $expr, %options) = @_; # Name of variable, initializing expression, options &Variable(0, @_) } sub Vw(*;$%) # Define a word variable {my ($name, $expr, %options) = @_; # Name of variable, initializing expression, options &Variable(1, @_) } sub Vd(*;$%) # Define a double word variable {my ($name, $expr, %options) = @_; # Name of variable, initializing expression, options &Variable(2, @_) } sub Vq(*;$%) # Define a quad variable {my ($name, $expr, %options) = @_; # Name of variable, initializing expression, options &Variable(3, @_) } sub Cq(*;$%) # Define a quad constant {my ($name, $expr, %options) = @_; # Name of variable, initializing expression, options &Variable(3, @_, constant=>1) } sub VxyzInit($@) # Initialize an xyz register from general purpose registers {my ($var, @expr) = @_; # Variable, initializing general purpose registers or undef if (@expr == 1 and $expr[0] =~ m(\Al)) # Load from the memory at the specified label {if ($var->size == 6) {PushR zmm0; Vmovdqu8 zmm0, "[".$expr[0]."]"; Vmovdqu8 $var->address, zmm0; PopR zmm0; return $var; } confess "More code needed"; } my $N = 2 ** ($var->size - 3); # Number of quads to fully initialize @expr <= $N or confess "$N initializers required"; my $l = $var->label; # Label my $s = RegisterSize(rax); # Size of initializers for my $i(keys @expr) # Each initializer {my $o = $s * $i; # Offset Mov "qword[$l+$o]", $expr[$i] if $expr[$i]; # Move in initial value if present } $var } sub Vx(*;@) # Define an xmm variable {my ($name, @expr) = @_; # Name of variable, initializing expression VxyzInit(&Variable(4, $name), @expr); } sub Vy(*;@) # Define an ymm variable {my ($name, @expr) = @_; # Name of variable, initializing expression VxyzInit(&Variable(5, $name), @expr); } sub Vz(*;@) # Define an zmm variable {my ($name, @expr) = @_; # Name of variable, initializing expression VxyzInit(&Variable(6, $name), @expr); } sub Vr(*;$) # Define a reference variable {my ($name, $size) = @_; # Name of variable, variable being referenced my $r = &Variable(3, $name); # The referring variable is 64 bits wide $r->reference = $size; # Mark variable as a reference $r # Size of the referenced variable } #D2 Operations # Variable operations if (1) # Define operator overloading for Variables {package Nasm::X86::Variable; use overload '+' => \&add, '-' => \&sub, '*' => \×, '/' => \÷, '%' => \&mod, '==' => \&eq, '!=' => \&ne, '>=' => \&ge, '>' => \>, '<=' => \&le, '<' => \<, '++' => \&inc, '--' => \&dec, '""' => \&str, '&' => \&and, '|' => \&or, '+=' => \&plusAssign, '-=' => \&minusAssign, '=' => \&equals, } sub Nasm::X86::Variable::address($;$) # Get the address of a variable with an optional offset {my ($left, $offset) = @_; # Left variable, optional offset my $o = $offset ? "+$offset" : ""; "[".$left-> label."$o]" } sub Nasm::X86::Variable::copy($$) # Copy one variable into another {my ($left, $right) = @_; # Left variable, right variable @_ == 2 or confess; ref($right) =~ m(Variable) or confess "Variable required"; my $l = $left ->address; my $r = $right->address; if ($left->size == 3 and $right->size == 3) {my $lr = $left ->reference; my $rr = $right->reference; Comment "Copy variable: ".$right->name.' to '.$left->name; PushR my @save = (r15); Mov r15, $r; if ($rr) {KeepFree r15; Mov r15, "[r15]"; } if (!$lr) {Mov $l, r15; } else {Comment "Copy ".$right->name.' to '.$left->name; PushR my @save2 = (r14); Mov r14, $l; Mov "[r14]", r15; PopR @save2; } PopR @save; return; } confess "Need more code"; } sub Nasm::X86::Variable::clone($) # Clone a variable to create a new variable {my ($var) = @_; # Variable to clone @_ == 1 or confess; my $a = $var->address; if ($var->size == 3) {Comment "Clone ".$var->name; my $new = Vq('Clone of '.$var->name); PushR my @save = (r15); Mov r15, $var->address; Mov $new->address, r15; PopR @save; $new->reference = $var->reference; return $new; } confess "Need more code"; } sub Nasm::X86::Variable::copyAddress($$) # Copy a reference to a variable {my ($left, $right) = @_; # Left variable, right variable $left->reference or confess "Left hand side must be a reference"; $left->size == 3 or confess "Left hand side must be size 3"; my $l = $left ->address; my $r = $right->address; if ($right->size == 3) {Comment "Copy parameter address"; PushR my @save = (r15); if ($right->reference) # Right is a reference so we copy its value {Mov r15, $r; } else # Right is not a reference so we copy its address {Lea r15, $r; } Mov $l, r15; # Save value of address in left PopR @save; return; } confess "Need more code"; } sub Nasm::X86::Variable::equals($$$) # Equals operator {my ($op, $left, $right) = @_; # Operator, left variable, right variable $op } sub Nasm::X86::Variable::assign($$$) # Assign to the left hand side the value of the right hand side {my ($left, $op, $right) = @_; # Left variable, operator, right variable $left->constant and confess "cannot assign to a constant"; if ($left->size == 3 and !ref($right) || $right->size == 3) {Comment "Variable assign"; PushR my @save = (r14, r15); Mov r14, $left ->address; if ($left->reference) # Dereference left if necessary {KeepFree r14; Mov r14, "[r14]"; } if (!ref($right)) # Load right constant {KeepFree r15; Mov r15, $right; } else # Load right variable {Mov r15, $right->address; if ($right->reference) # Dereference right if necessary {KeepFree r15; Mov r15, "[r15]"; } } &$op(r14, r15); if ($left->reference) # Store in reference on left if necessary {PushR r13; Mov r13, $left->address; Mov "[r13]", r14; PopR r13; } else # Store in variable {Mov $left ->address, r14; } PopR @save; return $left; } confess "Need more code"; } sub Nasm::X86::Variable::plusAssign($$) # Implement plus and assign {my ($left, $right) = @_; # Left variable, right variable $left->assign(\&Add, $right); } sub Nasm::X86::Variable::minusAssign($$) # Implement minus and assign {my ($left, $right) = @_; # Left variable, right variable $left->assign(\&Sub, $right); } sub Nasm::X86::Variable::arithmetic($$$$) # Return a variable containing the result of an arithmetic operation on the left hand and right hand side variables {my ($op, $name, $left, $right) = @_; # Operator, operator name, Left variable, right variable my $l = $left ->address; my $r = ref($right) ? $right->address : $right; # Right can be either a variable reference or a constant if ($left->size == 3 and !ref($right) || $right->size == 3) # Vq {PushR my @save = (r14, r15); Mov r15, $l; if ($left->reference) # Dereference left if necessary {KeepFree r15; Mov r15, "[r15]"; } Mov r14, $r; if (ref($right) and $right->reference) # Dereference right if necessary {KeepFree r14; Mov r14, "[r14]"; } &$op(r15, r14); my $v = Vq(join(' ', '('.$left->name, $name, (ref($right) ? $right->name : $right).')'), r15); PopR @save; return $v; } if ($left->size == 6 and ref($right) and $right->size == 6) # Vz {if ($name =~ m(add|sub)) {PushR my @save = (zmm0, zmm1); Vmovdqu64 zmm0, $left->address; Vmovdqu64 zmm1, $right->address; my $l = $left->laneSize // $right->laneSize // 0; # Size of elements to add my $o = substr("bwdq", $l, 1); # Size of operation eval "Vp$name$o zmm0, zmm0, zmm1"; # Add or subtract my $z = Vz(join(' ', $left->name, $op, $right->name)); # Variable to hold result Vmovdqu64 $z->address, zmm0; # Save result in variable PopR @save; return $z; } } confess "Need more code"; } sub Nasm::X86::Variable::add($$) # Add the right hand variable to the left hand variable and return the result as a new variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::arithmetic(\&Add, q(add), $left, $right); } sub Nasm::X86::Variable::sub($$) # Subtract the right hand variable from the left hand variable and return the result as a new variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::arithmetic(\&Sub, q(sub), $left, $right); } sub Nasm::X86::Variable::times($$) # Multiply the left hand variable by the right hand variable and return the result as a new variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::arithmetic(\&Imul, q(times), $left, $right); } sub Nasm::X86::Variable::division($$$) # Return a variable containing the result or the remainder that occurs when the left hand side is divided by the right hand side {my ($op, $left, $right) = @_; # Operator, Left variable, right variable my $l = $left ->address; my $r = ref($right) ? $right->address : $right; # Right can be either a variable reference or a constant if ($left->size == 3 and ! ref($right) || $right->size == 3) {PushR my @regs = (rax, rdx, r15); Mov rax, $l; Mov r15, $r; Idiv r15; my $v = Vq(join(' ', '('.$left->name, $op, (ref($right) ? $right->name : '').')'), $op eq "%" ? rdx : rax); PopR @regs; return $v; } confess "Need more code"; } sub Nasm::X86::Variable::divide($$) # Divide the left hand variable by the right hand variable and return the result as a new variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::division("/", $left, $right); } sub Nasm::X86::Variable::mod($$) # Divide the left hand variable by the right hand variable and return the remainder as a new variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::division("%", $left, $right); } sub Nasm::X86::Variable::boolean($$$$) # Combine the left hand variable with the right hand variable via a boolean operator {my ($sub, $op, $left, $right) = @_; # Operator, operator name, Left variable, right variable !ref($right) or ref($right) =~ m(Variable) or confess "Variable expected"; my $r = ref($right) ? $right->address : $right; # Right can be either a variable reference or a constant if ($left->size == 3) {PushR r15; Mov r15, $left ->address; if ($left->reference) # Dereference left if necessary {KeepFree r15; Mov r15, "[r15]"; } if (ref($right) and $right->reference) # Dereference on right if necessary {PushR r14; Mov r14, $right ->address; KeepFree r14; Mov r14, "[r14]"; Cmp r15, r14; } elsif (ref($right)) # Variable but not a reference on the right {Cmp r15, $right->address; } else # Constant on the right {Cmp r15, $right; } KeepFree r15; &$sub(sub {Mov r15, 1; KeepFree r15}, sub {Mov r15, 0; KeepFree r15}); my $v = Vq(join(' ', '('.$left->name, $op, (ref($right) ? $right->name : '').')'), r15); PopR r15; return $v; } confess "Need more code"; } sub Nasm::X86::Variable::eq($$) # Check whether the left hand variable is equal to the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfEq, q(eq), $left, $right); } sub Nasm::X86::Variable::ne($$) # Check whether the left hand variable is not equal to the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfNe, q(ne), $left, $right); } sub Nasm::X86::Variable::ge($$) # Check whether the left hand variable is greater than or equal to the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfGe, q(ge), $left, $right); } sub Nasm::X86::Variable::gt($$) # Check whether the left hand variable is greater than the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfGt, q(gt), $left, $right); } sub Nasm::X86::Variable::le($$) # Check whether the left hand variable is less than or equal to the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfLe, q(le), $left, $right); } sub Nasm::X86::Variable::lt($$) # Check whether the left hand variable is less than the right hand variable {my ($left, $right) = @_; # Left variable, right variable Nasm::X86::Variable::boolean(\&IfLt, q(lt), $left, $right); } #D2 Print variables # Print the values of variables or the memory addressed by them sub Nasm::X86::Variable::dump($$$;$$) # Dump the value of a variable to the specified channel adding an optional title and new line if requested {my ($left, $channel, $newLine, $title1, $title2) = @_; # Left variable, channel, new line required, optional leading title, optional trailing title @_ >= 3 or confess; if ($left->size == 3) # General purpose register {PushR my @regs = (rax, rdi); Mov rax, $left->label; # Address in memory KeepFree rax; if ($left->reference) {Mov rax, "[rax]"; KeepFree rax; } Mov rax, "[rax]"; confess dump($channel) unless $channel =~ m(\A1|2\Z); PrintString ($channel, $title1//$left->name.": "); PrintRaxInHex($channel); PrintString ($channel, $title2) if defined $title2; PrintNL ($channel) if $newLine; PopR @regs; } elsif ($left->size == 4) # xmm {PushR my @regs = (rax, rdi); my $l = $left->label; # Address in memory my $s = RegisterSize rax; Mov rax, "[$l]"; Mov rdi, "[$l+$s]"; &PrintErrString($title1//$left->name.": "); &PrintErrRaxInHex(); &PrintErrString(" "); KeepFree rax; Mov rax, rdi; &PrintErrRaxInHex(); &PrintErrNL(); PopR @regs; } } sub Nasm::X86::Variable::err($;$$) # Dump the value of a variable on stderr {my ($left, $title1, $title2) = @_; # Left variable, optional leading title, optional trailing title $left->dump($stderr, 0, $title1, $title2); } sub Nasm::X86::Variable::out($;$$) # Dump the value of a variable on stdout {my ($left, $title1, $title2) = @_; # Left variable, optional leading title, optional trailing title $left->dump($stdout, 0, $title1, $title2); } sub Nasm::X86::Variable::errNL($;$$) # Dump the value of a variable on stderr and append a new line {my ($left, $title1, $title2) = @_; # Left variable, optional leading title, optional trailing title $left->dump($stderr, 1, $title1, $title2); } sub Nasm::X86::Variable::outNL($;$$) # Dump the value of a variable on stdout and append a new line {my ($left, $title1, $title2) = @_; # Left variable, optional leading title, optional trailing title $left->dump($stdout, 1, $title1, $title2); } sub Nasm::X86::Variable::debug($) # Dump the value of a variable on stdout with an indication of where the dump came from {my ($left) = @_; # Left variable PushR my @regs = (rax, rdi); Mov rax, $left->label; # Address in memory KeepFree rax; Mov rax, "[rax]"; &PrintErrString(pad($left->name, 32).": "); &PrintErrRaxInHex(); my ($p, $f, $l) = caller(0); # Position of caller in file &PrintErrString(" at $f line $l"); &PrintErrNL(); PopR @regs; } sub Nasm::X86::Variable::isRef($) # Check whether the specified variable is a reference to another variable {my ($variable) = @_; # Variable my $n = $variable->name; # Variable name $variable->size == 3 or confess "Wrong size for reference: $n"; $variable->reference } sub Nasm::X86::Variable::setReg($$@) # Set the named registers from the content of the variable {my ($variable, $register, @registers) = @_; # Variable, register to load, optional further registers to load if ($variable->size == 3) # General purpose register {if ($variable->isRef) {Mov $register, $variable->address; KeepFree $register; Mov $register, "[$register]"; } else {Mov $register, $variable->address; } } elsif ($variable->size == 4) # Xmm {Mov $register, $variable->address; for my $i(keys @registers) {Mov $registers[$i], $variable->address(($i + 1) * RegisterSize rax); } } else {confess "More code needed"; } $register } sub Nasm::X86::Variable::getReg($$@) # Load the variable from the named registers {my ($variable, $register, @registers) = @_; # Variable, register to load, optional further registers to load from if ($variable->size == 3) {if ($variable->isRef) # Move to the location referred to by this variable {$Registers{$register} or confess "No such register: $register"; # Check we have been given a register Comment "Get variable value from register $register"; my $r = $register eq r15 ? r14 : r15; PushR $r; Mov $r, $variable->address; Mov "[$r]", $register; PopR $r; } else # Move to this variable {Mov $variable->address, $register; } } elsif ($variable->size == 4) # Xmm {Mov $variable->address, $register; for my $i(keys @registers) {Mov $variable->address(($i + 1) * RegisterSize rax), $registers[$i]; } } else {confess "More code needed"; } } sub Nasm::X86::Variable::getConst($$) # Load the variable from a constant in effect setting a variable to a specified value {my ($variable, $constant) = @_; # Variable, constant to load if ($variable->size == 3) {PushR my @save = (r14, r15); Comment "Load constant $constant into variable: ".$variable->name; Mov r15, $constant; Lea r14, $variable->address; Mov "[r14]", r15; PopR @save; } else {confess "More code needed"; } } sub Nasm::X86::Variable::incDec($$) # Increment or decrement a variable {my ($left, $op) = @_; # Left variable operator, address of operator to perform inc or dec $left->constant and confess "Cannot increment or decrement a constant"; my $l = $left->address; if ($left->size == 3) {if ($left->reference) {PushR my @save = (r14, r15); Mov r15, $l; KeepFree r15; Mov r14, "[r15]"; &$op(r14); Mov "[r15]", r14; PopR @save; return $left; } else {PushR r15; Mov r15, $l; &$op(r15); Mov $l, r15; PopR r15; return $left; } } confess "Need more code"; } sub Nasm::X86::Variable::inc($) # Increment a variable {my ($left) = @_; # Variable $left->incDec(\&Inc); } sub Nasm::X86::Variable::dec($) # Decrement a variable {my ($left) = @_; # Variable $left->incDec(\&Dec); } sub Nasm::X86::Variable::str($) # The name of the variable {my ($left) = @_; # Variable $left->name; } sub Nasm::X86::Variable::min($$) # Minimum of two variables {my ($left, $right) = @_; # Left variable, Right variable, PushR my @save = (r12, r14, r15); $left->setReg(r14); $right->setReg(r15); Cmp r14, r15; IfLt(sub {Mov r12, r14; KeepFree r12}, sub {Mov r12, r15; KeepFree r12}); my $r = Vq("Minimum(".$left->name.", ".$right->name.")", r12); PopR @save; $r } sub Nasm::X86::Variable::max($$) # Maximum of two variables {my ($left, $right) = @_; # Left variable, Right variable, PushR my @save = (r12, r14, r15); $left->setReg(r14); $right->setReg(r15); Cmp r14, r15; &IfGt(sub {Mov r12, r14; KeepFree r12}, sub {Mov r12, r15; KeepFree r12}); my $r = Vq("Maximum(".$left->name.", ".$right->name.")", r12); PopR @save; $r } sub Nasm::X86::Variable::and($$) # And two variables {my ($left, $right) = @_; # Left variable, right variable PushR my @save = (r14, r15); Mov r14, 0; $left->setReg(r15); Cmp r15, 0; KeepFree r15; &IfNe ( sub {$right->setReg(r15); Cmp r15, 0; &IfNe(sub {Add r14, 1}); } ); my $r = Vq("And(".$left->name.", ".$right->name.")", r14); PopR @save; $r } sub Nasm::X86::Variable::or($$) # Or two variables {my ($left, $right) = @_; # Left variable, right variable PushR my @save = (r14, r15); Mov r14, 1; $left->setReg(r15); KeepFree r14, r15; Cmp r15, 0; &IfEq ( sub {$right->setReg(r15); Cmp r15, 0; &IfEq(sub {Mov r14, 0}); } ); my $r = Vq("Or(".$left->name.", ".$right->name.")", r14); PopR @save; $r } sub Nasm::X86::Variable::setMask($$$) # Set the mask register to ones starting at the specified position for the specified length and zeroes elsewhere {my ($start, $length, $mask) = @_; # Variable containing start of mask, variable containing length of mask, mask register @_ == 3 or confess; PushR my @save = (r13, r14, r15); Mov r15, -1; if ($start) # Non zero start {$start->setReg(r14); Bzhi r15, r15, r14; Not r15; ref($length) or confess "Not a variable"; $length->setReg(r13); Add r14, r13; } else # Starting at zero {confess "Deprecated: use setMaskFirst instead"; $length->setReg(r13); Mov r14, $length; } Bzhi r15, r15, r14; Kmovq $mask, r15; PopR @save; } sub Nasm::X86::Variable::setMaskFirst($$) # Set the first bits in the specified mask register {my ($length, $mask) = @_; # Variable containing length to set, mask register @_ == 2 or confess; PushR my @save = (r14, r15); Mov r15, -1; $length->setReg(r14); Bzhi r15, r15, r14; Kmovq $mask, r15; PopR @save; } sub Nasm::X86::Variable::setMaskBit($$) # Set a bit in the specified mask register retaining the other bits {my ($length, $mask) = @_; # Variable containing bit position to set, mask register @_ == 2 or confess; PushR my @save = (r14, r15); Kmovq r15, $mask; $length->setReg(r14); Bts r15, r14; Kmovq $mask, r15; PopR @save; } sub Nasm::X86::Variable::clearMaskBit($$) # Clear a bit in the specified mask register retaining the other bits {my ($length, $mask) = @_; # Variable containing bit position to clear, mask register @_ == 2 or confess; PushR my @save = (r14, r15); Kmovq r15, $mask; $length->setReg(r14); Btc r15, r14; Kmovq $mask, r15; PopR @save; } sub Nasm::X86::Variable::setZmm($$$$) # Load bytes from the memory addressed by specified source variable into the numbered zmm register at the offset in the specified offset moving the number of bytes in the specified variable {my ($source, $zmm, $offset, $length) = @_; # Variable containing the address of the source, number of zmm to load, variable containing offset in zmm to move to, variable containing length of move @_ == 4 or confess; ref($offset) && ref($length) or confess "Missing variable"; # Need variables of offset and length Comment "Set Zmm $zmm from Memory"; PushR my @save = (k7, r14, r15); $offset->setMask($length, k7); # Set mask for target $source->setReg(r15); $offset->setReg(r14); # Position memory for target Sub r15, r14; # Position memory for target Vmovdqu8 "zmm${zmm}{k7}", "[r15]"; # Read from memory PopR @save; } sub Nasm::X86::Variable::loadZmm($$) # Load bytes from the memory addressed by the specified source variable into the numbered zmm register. {my ($source, $zmm) = @_; # Variable containing the address of the source, number of zmm to get @_ == 2 or confess; if ($source->size == 3) # Load through memory addressed by a Vq {Comment "Load zmm$zmm from memory addressed by ".$source->name; PushR r15; $source->setReg(r15); Vmovdqu8 "zmm$zmm", "[r15]"; PopR r15; } elsif ($source->size == 6) # Load from Vz {Comment "Load zmm$zmm from ".$source->name; Vmovdqu8 "zmm$zmm", $source->address; } } sub Nasm::X86::Variable::saveZmm2222($$) # Save bytes into the memory addressed by the target variable from the numbered zmm register. {my ($target, $zmm) = @_; # Variable containing the address of the source, number of zmm to put @_ == 2 or confess; Comment "Save zmm$zmm into memory addressed by ".$target->name; PushR r15; $target->setReg(r15); Vmovdqu8 "[r15]", "zmm$zmm"; # Write into memory PopR r15; } sub getBwdqFromMm($$$) # Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable {my ($size, $mm, $offset) = @_; # Size of get, register, offset in bytes either as a constant or as a variable @_ == 3 or confess; my $o; # The offset into the mm register if (ref($offset)) # The offset is being passed in a variable {my $name = $offset->name; Comment "Get $size at $name in $mm"; PushR ($o = r14); $offset->setReg($o); } else # The offset is being passed as a register expression {$o = $offset; Comment "Get $size at $offset in $mm"; $offset =~ m(r15) and confess "Cannot pass offset: '$offset', in r15, choose another register"; } PushR r15; PushRR $mm; ##Rewrite using masked move rather than stack # Push source register if ($size !~ m(q)) # Clear the register if necessary {ClearRegisters r15; KeepFree r15; } Mov r15b, "[rsp+$o]" if $size =~ m(b); # Load byte register from offset Mov r15w, "[rsp+$o]" if $size =~ m(w); # Load word register from offset Mov r15d, "[rsp+$o]" if $size =~ m(d); # Load double word register from offset Mov r15, "[rsp+$o]" if $size =~ m(q); # Load register from offset Add rsp, RegisterSize $mm; # Pop source register my $v = Vq("$size at offset $offset in $mm", r15); # Create variable $v->getReg(r15); # Load variable PopR r15; PopR $o if ref($offset); # The offset is being passed in a variable $v # Return variable } sub getBFromXmm($$) # Get the byte from the numbered xmm register and return it in a variable {my ($xmm, $offset) = @_; # Numbered xmm, offset in bytes getBwdqFromMm('b', "xmm$xmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered xmm register and return it in a variable } sub getWFromXmm($$) # Get the word from the numbered xmm register and return it in a variable {my ($xmm, $offset) = @_; # Numbered xmm, offset in bytes getBwdqFromMm('w', "xmm$xmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered xmm register and return it in a variable } sub getDFromXmm($$) # Get the double word from the numbered xmm register and return it in a variable {my ($xmm, $offset) = @_; # Numbered xmm, offset in bytes getBwdqFromMm('d', "xmm$xmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered xmm register and return it in a variable } sub getQFromXmm($$) # Get the quad word from the numbered xmm register and return it in a variable {my ($xmm, $offset) = @_; # Numbered xmm, offset in bytes getBwdqFromMm('q', "xmm$xmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered xmm register and return it in a variable } sub getBFromZmm($$) # Get the byte from the numbered zmm register and return it in a variable {my ($zmm, $offset) = @_; # Numbered zmm, offset in bytes getBwdqFromMm('b', "zmm$zmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable } sub getWFromZmm($$) # Get the word from the numbered zmm register and return it in a variable {my ($zmm, $offset) = @_; # Numbered zmm, offset in bytes getBwdqFromMm('w', "zmm$zmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable } sub getDFromZmm($$) # Get the double word from the numbered zmm register and return it in a variable {my ($zmm, $offset) = @_; # Numbered zmm, offset in bytes getBwdqFromMm('d', "zmm$zmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable } sub getQFromZmm($$) # Get the quad word from the numbered zmm register and return it in a variable {my ($zmm, $offset) = @_; # Numbered zmm, offset in bytes getBwdqFromMm('q', "zmm$zmm", $offset) # Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable } sub Nasm::X86::Variable::getBFromZmm($$$) # Get the byte from the numbered zmm register and put it in a variable {my ($variable, $zmm, $offset) = @_; # Variable, numbered zmm, offset in bytes $variable->copy(getBwdqFromMm('b', "zmm$zmm", $offset)) # Get the numbered byte|word|double word|quad word from the numbered zmm register and put it in a variable } sub Nasm::X86::Variable::getWFromZmm($$$) # Get the word from the numbered zmm register and put it in a variable {my ($variable, $zmm, $offset) = @_; # Variable, numbered zmm, offset in bytes $variable->copy(getBwdqFromMm('w', "zmm$zmm", $offset)) # Get the numbered byte|word|double word|quad word from the numbered zmm register and put it in a variable } sub Nasm::X86::Variable::getDFromZmm($$$) # Get the double word from the numbered zmm register and put it in a variable {my ($variable, $zmm, $offset) = @_; # Variable, numbered zmm, offset in bytes $variable->copy(getBwdqFromMm('d', "zmm$zmm", $offset)) # Get the numbered byte|word|double word|quad word from the numbered zmm register and put it in a variable } sub Nasm::X86::Variable::getQFromZmm($$$) # Get the quad word from the numbered zmm register and put it in a variable {my ($variable, $zmm, $offset) = @_; # Variable, numbered zmm, offset in bytes $variable->copy(getBwdqFromMm('q', "zmm$zmm", $offset)) # Get the numbered byte|word|double word|quad word from the numbered zmm register and put it in a variable } sub Nasm::X86::Variable::putBwdqIntoMm($$$$) # Place the value of the content variable at the byte|word|double word|quad word in the numbered zmm register {my ($content, $size, $mm, $offset) = @_; # Variable with content, size of put, numbered zmm, offset in bytes @_ == 4 or confess; my $o; # The offset into the mm register if (ref($offset)) # The offset is being passed in a variable {my $name = $offset->name; Comment "Put $size at $name in $mm"; PushR ($o = r14); $offset->setReg($o); } else # The offset is being passed as a register expression {$o = $offset; Comment "Put $size at $offset in $mm"; $offset =~ m(r15) and confess "Cannot pass offset: '$offset', in r15, choose another register"; } PushR my @save=(r15, $mm); # Rewrite using masked move # Push target register $content->setReg(r15); Mov "[rsp+$o]", r15b if $size =~ m(b); # Write byte register Mov "[rsp+$o]", r15w if $size =~ m(w); # Write word register Mov "[rsp+$o]", r15d if $size =~ m(d); # Write double word register Mov "[rsp+$o]", r15 if $size =~ m(q); # Write register PopR @save; PopR $o if ref($offset); # The offset is being passed in a variable } sub Nasm::X86::Variable::putBIntoXmm($$$) # Place the value of the content variable at the byte in the numbered xmm register {my ($content, $xmm, $offset) = @_; # Variable with content, numbered xmm, offset in bytes $content->putBwdqIntoMm('b', "xmm$xmm", $offset) # Place the value of the content variable at the word in the numbered xmm register } sub Nasm::X86::Variable::putWIntoXmm($$$) # Place the value of the content variable at the word in the numbered xmm register {my ($content, $xmm, $offset) = @_; # Variable with content, numbered xmm, offset in bytes $content->putBwdqIntoMm('w', "xmm$xmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered xmm register } sub Nasm::X86::Variable::putDIntoXmm($$$) # Place the value of the content variable at the double word in the numbered xmm register {my ($content, $xmm, $offset) = @_; # Variable with content, numbered xmm, offset in bytes $content->putBwdqIntoMm('d', "xmm$xmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered xmm register } sub Nasm::X86::Variable::putQIntoXmm($$$) # Place the value of the content variable at the quad word in the numbered xmm register {my ($content, $xmm, $offset) = @_; # Variable with content, numbered xmm, offset in bytes $content->putBwdqIntoMm('q', "xmm$xmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered xmm register } sub Nasm::X86::Variable::putBIntoZmm($$$) # Place the value of the content variable at the byte in the numbered zmm register {my ($content, $zmm, $offset) = @_; # Variable with content, numbered zmm, offset in bytes $zmm =~ m(\A(0|1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\Z) or confess; $content->putBwdqIntoMm('b', "zmm$zmm", $offset) # Place the value of the content variable at the word in the numbered zmm register } sub Nasm::X86::Variable::putWIntoZmm($$$) # Place the value of the content variable at the word in the numbered zmm register {my ($content, $zmm, $offset) = @_; # Variable with content, numbered zmm, offset in bytes $zmm =~ m(\A(0|1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\Z) or confess; $content->putBwdqIntoMm('w', "zmm$zmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered zmm register } sub Nasm::X86::Variable::putDIntoZmm($$$) # Place the value of the content variable at the double word in the numbered zmm register {my ($content, $zmm, $offset) = @_; # Variable with content, numbered zmm, offset in bytes $zmm =~ m(\A(0|1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\Z) or confess; $content->putBwdqIntoMm('d', "zmm$zmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered zmm register } sub Nasm::X86::Variable::putQIntoZmm($$$) # Place the value of the content variable at the quad word in the numbered zmm register {my ($content, $zmm, $offset) = @_; # Variable with content, numbered zmm, offset in bytes $zmm =~ m(\A(0|1|2|3|4|5|6|7|8|9|10|11|12|13|14|15|16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\Z) or confess; $content->putBwdqIntoMm('q', "zmm$zmm", $offset) # Place the value of the content variable at the byte|word|double word|quad word in the numbered zmm register } #D2 Broadcast # Broadcast from a variable into a zmm sub Nasm::X86::Variable::zBroadCastD($$) # Broadcast a double word in a variable into the numbered zmm. {my ($variable, $zmm) = @_; # Variable containing value to broadcast, numbered zmm to broadcast to PushR my @save = (r15); $variable->setReg(r15); # Value of variable Vpbroadcastd "zmm".$zmm, r15d; # Broadcast PopR @save; } #D2 Stack # Push and pop variables to and from the stack sub Nasm::X86::Variable::push($) # Push a variable onto the stack {my ($variable) = @_; # Variable $variable->size == 3 or confess "Wrong size"; PushR rax; Push rax; # Make a slot on the stack and save rax $variable->setReg(rax); # Variable to rax my $s = RegisterSize rax; # Size of rax Mov "[rsp+$s]", rax; # Move variable to slot PopR rax; # Remove rax to leave variable on top of the stack } sub Nasm::X86::Variable::pop($) # Pop a variable from the stack {my ($variable) = @_; # Variable $variable->size == 3 or confess "Wrong size"; PushR rax; # Liberate a register my $s = RegisterSize rax; # Size of rax Mov rax, "[rsp+$s]"; # Load from stack $variable->getReg(rax); # Variable to rax PopR rax; # Remove rax to leave variable on top of the stack Add rsp, $s; # Remove variable from stack } #D2 Memory # Actions on memory described by variables sub Nasm::X86::Variable::clearMemory($$) # Clear the memory described in this variable {my ($address, $size) = @_; # Address of memory to clear, size of the memory to clear $address->name eq q(address) or confess "Need address"; $size->name eq q(size) or confess "Need size"; &ClearMemory(size=>$size, address=>$address); # Free the memory } sub Nasm::X86::Variable::copyMemory($$$) # Copy from one block of memory to another {my ($target, $source, $size) = @_; # Address of target, address of source, length to copy $target->name eq q(target) or confess "Need target"; $source->name eq q(source) or confess "Need source"; $size ->name eq q(size) or confess "Need size"; &CopyMemory(target => $target, source => $source, size => $size); # Copy the memory } sub Nasm::X86::Variable::printMemoryInHexNL($$$) # Write the memory addressed by a variable to stdout or stderr {my ($address, $channel, $size) = @_; # Address of memory, channel to print on, number of bytes to print $address->name eq q(address) or confess "Need address"; $size ->name eq q(size) or confess "Need size"; PushR my @save = (rax, rdi); $address->setReg(rax); $size->setReg(rdi); &PrintMemoryInHex($channel); &PrintNL($channel); PopR @save; } sub Nasm::X86::Variable::printErrMemoryInHexNL($$) # Write the memory addressed by a variable to stderr {my ($address, $size) = @_; # Address of memory, number of bytes to print $address->printMemoryInHexNL($stderr, $size); } sub Nasm::X86::Variable::printOutMemoryInHexNL($$) # Write the memory addressed by a variable to stdout {my ($address, $size) = @_; # Address of memory, number of bytes to print $address->printMemoryInHexNL($stdout, $size); } sub Nasm::X86::Variable::freeMemory($$) # Free the memory addressed by this variable for the specified length {my ($address, $size) = @_; # Address of memory to free, size of the memory to free $address->name eq q(address) or confess "Need address"; $size ->name eq q(size) or confess "Need size"; &FreeMemory(size=>$size, address=>$address); # Free the memory } sub Nasm::X86::Variable::allocateMemory(@) # Allocate the specified amount of memory via mmap and return its address {my ($size) = @_; # Size @_ >= 1 or confess; $size->name eq q(size) or confess "Need size"; &AllocateMemory(size => $size, my $a = Vq(address)); $a } #D2 Structured Programming with variables # Structured programming operations driven off variables. sub Nasm::X86::Variable::for($&) # Iterate the body limit times. {my ($limit, $body) = @_; # Limit, Body @_ == 2 or confess; Comment "Variable::For $limit"; my $index = Vq(q(index), 0); # The index that will be incremented my $start = Label; my $next = Label; my $end = Label; SetLabel $start; # Start of loop If ($index >= $limit, sub{Jge $end}); # Condition &$body($index, $start, $next, $end); # Execute body SetLabel $next; # Next iteration $index++; # Increment Jmp $start; SetLabel $end; } #D1 Stack # Manage data on the stack #D2 Push, Pop, Peek # Generic versions of push, pop, peek sub PushRR(@) #P Push registers onto the stack without tracking {my (@r) = @_; # Register for my $r(@r) {my $size = RegisterSize $r; $size or confess "No such register: $r"; if ($size > 8) # Wide registers {Sub rsp, $size; Vmovdqu32 "[rsp]", $r; } elsif ($r =~ m(\Ak)) # Mask as they do not respond to push {Sub rsp, $size; Kmovq "[rsp]", $r; } else # Normal register {Push $r; } } } sub PushR(@) #P Push registers onto the stack {my (@r) = @_; # Register PushRR @r; # Push KeepPush @r; # Track } sub PopRR(@) #P Pop registers from the stack without tracking {my (@r) = @_; # Register for my $r(reverse @r) # Pop registers in reverse order {my $size = RegisterSize $r; if ($size > 8) {Vmovdqu32 $r, "[rsp]"; Add rsp, $size; } elsif ($r =~ m(\Ak)) {Kmovq $r, "[rsp]"; Add rsp, $size; } else {Pop $r; } } } sub PopR(@) # Pop registers from the stack {my (@r) = @_; # Register PopRR @r; # Pop registers from the stack without tracking KeepPop @r; # Track } sub PopEax() # We cannot pop a double word from the stack in 64 bit long mode using pop so we improvise {my $l = RegisterSize eax; # eax is half rax Mov eax, "[rsp]"; Add rsp, RegisterSize eax; } sub PeekR($) # Peek at register on stack {my ($r) = @_; # Register my $size = RegisterSize $r; if ($size > 8) # x|y|zmm* {Vmovdqu32 $r, "[rsp]"; } else # 8 byte register {Mov $r, "[rsp]"; } } #D2 Declarations # Declare variables and structures #D3 Structures # Declare a structure sub Structure() # Create a structure addressed by a register {@_ == 0 or confess; my $local = genHash(__PACKAGE__."::Structure", size => 0, variables => [], ); } sub Nasm::X86::Structure::field($$;$) # Add a field of the specified length with an optional comment {my ($structure, $length, $comment) = @_; # Structure data descriptor, length of data, optional comment @_ >= 2 or confess; my $variable = genHash(__PACKAGE__."::StructureField", structure => $structure, # Structure containing the field loc => $structure->size, # Offset of the field size => $length, # Size of the field comment => $comment # Comment describing the purpose of the field ); $structure->size += $length; # Update size of local data push $structure->variables->@*, $variable; # Save variable $variable } sub Nasm::X86::StructureField::addr($;$) # Address a field in a structure by either the default register or the named register {my ($field, $register) = @_; # Field, optional address register else rax @_ <= 2 or confess; my $loc = $field->loc; # Offset of field in structure my $reg = $register || 'rax'; # Register locating the structure "[$loc+$reg]" # Address field } sub All8Structure($) # Create a structure consisting of 8 byte fields {my ($N) = @_; # Number of variables required @_ == 1 or confess; my $s = Structure; # Structure of specified size based on specified register my @f; my $z = RegisterSize rax; for(1..$N) # Create the variables {push @f, $s->field($z); } ($s, @f) # Structure, fields } #D3 Stack Frame # Declare local variables in a frame on the stack sub LocalData() # Map local data {@_ == 0 or confess; my $local = genHash(__PACKAGE__."::LocalData", size => 0, variables => [], ); } sub Nasm::X86::LocalData::start($) # Start a local data area on the stack {my ($local) = @_; # Local data descriptor @_ == 1 or confess; my $size = $local->size; # Size of local data Push rbp; Mov rbp,rsp; Sub rsp, $size; } sub Nasm::X86::LocalData::free($) # Free a local data area on the stack {my ($local) = @_; # Local data descriptor @_ == 1 or confess; Mov rsp, rbp; Pop rbp; } sub Nasm::X86::LocalData::variable($$;$) # Add a local variable {my ($local, $length, $comment) = @_; # Local data descriptor, length of data, optional comment @_ >= 2 or confess; my $variable = genHash(__PACKAGE__."::LocalVariable", loc => $local->size, size => $length, comment => $comment ); $local->size += $length; # Update size of local data $variable } sub Nasm::X86::LocalVariable::stack($) # Address a local variable on the stack {my ($variable) = @_; # Variable @_ == 1 or confess; my $l = $variable->loc; # Location of variable on stack my $S = $variable->size; my $s = $S == 8 ? 'qword' : $S == 4 ? 'dword' : $S == 2 ? 'word' : 'byte'; # Variable size "${s}[rbp-$l]" # Address variable - offsets are negative per Tino } sub Nasm::X86::LocalData::allocate8($@) # Add some 8 byte local variables and return an array of variable definitions {my ($local, @comments) = @_; # Local data descriptor, optional comment my @v; for my $c(@comments) {push @v, Nasm::X86::LocalData::variable($local, 8, $c); } wantarray ? @v : $v[-1]; # Avoid returning the number of elements accidently } sub AllocateAll8OnStack($) # Create a local data descriptor consisting of the specified number of 8 byte local variables and return an array: (local data descriptor, variable definitions...) {my ($N) = @_; # Number of variables required my $local = LocalData; # Create local data descriptor my @v; for(1..$N) # Create the variables {my $v = $local->variable(RegisterSize(rax)); push @v, $v->stack; } $local->start; # Create the local data area on the stack ($local, @v) } #D1 Operating system # Interacting with the operating system. #D2 Processes # Create and manage processes sub Fork() # Fork {@_ == 0 or confess; Comment "Fork"; Mov rax, 57; Syscall } sub GetPid() # Get process identifier {@_ == 0 or confess; Comment "Get Pid"; Mov rax, 39; Syscall } sub GetPidInHex() # Get process identifier in hex as 8 zero terminated bytes in rax {@_ == 0 or confess; Comment "Get Pid"; my $hexTranslateTable = hexTranslateTable; my $sub = Macro {SaveFirstFour; Mov rax, 39; # Get pid Syscall; Mov rdx, rax; # Content to be printed KeepFree rax; ClearRegisters rax; # Save a trailing 00 on the stack Push ax; for my $i(reverse 5..7) {my $s = 8*$i; KeepFree rax, rdi; Mov rdi,rdx; Shl rdi,$s; # Push selected byte high Shr rdi,56; # Push select byte low Shl rdi,1; # Multiply by two because each entry in the translation table is two bytes long Mov ax, "[$hexTranslateTable+rdi]"; Push ax; } Pop rax; # Get result from stack RestoreFirstFourExceptRax; } name => "GetPidInHex"; Call $sub; } sub GetPPid() # Get parent process identifier {@_ == 0 or confess; Comment "Get Parent Pid"; Mov rax, 110; Syscall } sub GetUid() # Get userid of current process {@_ == 0 or confess; Comment "Get User id"; Mov rax, 102; Syscall } sub WaitPid() # Wait for the pid in rax to complete {@_ == 0 or confess; Comment "WaitPid - wait for the pid in rax"; my $sub = Macro {SaveFirstSeven; Mov rdi,rax; Mov rax, 61; Mov rsi, 0; Mov rdx, 0; Mov r10, 0; Syscall; RestoreFirstSevenExceptRax; } name => "WaitPid"; Call $sub; } sub ReadTimeStampCounter() # Read the time stamp counter and return the time in nanoseconds in rax {@_ == 0 or confess; my $sub = Macro {Comment "Read Time-Stamp Counter"; Push rdx; Rdtsc; Shl rdx,32; Or rax,rdx; Pop rdx; } name => "ReadTimeStampCounter"; Call $sub; } #D2 Memory # Allocate and print memory sub PrintMemoryInHex($) # Dump memory from the address in rax for the length in rdi on the specified channel. As this method prints in blocks of 8 up to 7 bytes will be missing from the end unless the length is a multiple of 8 . {my ($channel) = @_; # Channel @_ == 1 or confess; Comment "Print out memory in hex on channel: $channel"; Call Macro {my $size = RegisterSize rax; SaveFirstFour; Mov rsi, rax; # Position in memory Lea rdi,"[rax+rdi-$size+1]"; # Upper limit of printing with an 8 byte register For # Print string in blocks {Mov rax, "[rsi]"; Bswap rax; PrintRaxInHex($channel); } rsi, rdi, $size; RestoreFirstFour; } name=> "PrintOutMemoryInHexOnChannel$channel"; } sub PrintErrMemoryInHex # Dump memory from the address in rax for the length in rdi on stderr {@_ == 0 or confess; PrintMemoryInHex($stderr); } sub PrintOutMemoryInHex # Dump memory from the address in rax for the length in rdi on stdout {@_ == 0 or confess; PrintMemoryInHex($stdout); } sub PrintErrMemoryInHexNL # Dump memory from the address in rax for the length in rdi and then print a new line {@_ == 0 or confess; PrintMemoryInHex($stderr); PrintNL($stderr); } sub PrintOutMemoryInHexNL # Dump memory from the address in rax for the length in rdi and then print a new line {@_ == 0 or confess; PrintMemoryInHex($stdout); PrintNL($stdout); } sub PrintMemory # Print the memory addressed by rax for a length of rdi on the specified channel {my ($channel) = @_; # Channel @_ == 1 or confess; Call Macro {Comment "Print memory on channel: $channel"; SaveFirstFour rax, rdi; Mov rsi, rax; Mov rdx, rdi; KeepFree rax, rdi; Mov rax, 1; Mov rdi, $channel; Syscall; RestoreFirstFour(); } name => "PrintOutMemoryOnChannel$channel"; } sub PrintErrMemory # Print the memory addressed by rax for a length of rdi on stderr {@_ == 0 or confess; PrintMemory($stdout); } sub PrintOutMemory # Print the memory addressed by rax for a length of rdi on stdout {@_ == 0 or confess; PrintMemory($stdout); } sub PrintErrMemoryNL # Print the memory addressed by rax for a length of rdi followed by a new line on stderr {@_ == 0 or confess; PrintErrMemory; PrintErrNL; } sub PrintOutMemoryNL # Print the memory addressed by rax for a length of rdi followed by a new line on stdout {@_ == 0 or confess; PrintOutMemory; PrintOutNL; } sub AllocateMemory(@) # Allocate the specified amount of memory via mmap and return its address {my (@variables) = @_; # Parameters @_ >= 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Allocate memory"; SaveFirstSeven; my $d = extractMacroDefinitionsFromCHeaderFile "linux/mman.h"; # mmap constants my $pa = $$d{MAP_PRIVATE} | $$d{MAP_ANONYMOUS}; my $wr = $$d{PROT_WRITE} | $$d{PROT_READ}; Mov rax, 9; # mmap $$p{size}->setReg(rsi); # Amount of memory Xor rdi, rdi; # Anywhere Mov rdx, $wr; # Read write protections Mov r10, $pa; # Private and anonymous map Mov r8, -1; # File descriptor for file backing memory if any Mov r9, 0; # Offset into file Syscall; Cmp rax, -12; # Check return code IfEq(sub {PrintErrString "Cannot allocate memory, "; $$p{size}->errNL; Exit(1); }); $$p{address}->getReg(rax); # Amount of memory RestoreFirstSeven; } in => {size => 3}, out => {address => 3}; $s->call(@variables); } sub FreeMemory(@) # Free memory {my (@variables) = @_; # Variables @_ >= 2 or confess; Comment "Free memory"; my $s = Subroutine {my ($p) = @_; # Parameters SaveFirstFour; Mov rax, 11; # Munmap $$p{address}->setReg(rdi); # Address $$p{size} ->setReg(rsi); # Length Syscall; RestoreFirstFour; } in => {size => 3, address => 3}; $s->call(@variables); } sub ClearMemory(@) # Clear memory - the address of the memory is in rax, the length in rdi {my (@variables) = @_; # Variables @_ >= 2 or confess; Comment "Clear memory"; my $s = Subroutine {my ($p) = @_; # Parameters PushR my @save = (k7, zmm0, rax, rdi, rsi, rdx); $$p{address}->setReg(rax); $$p{size} ->setReg(rdi); Lea rdx, "[rax+rdi]"; # Address of upper limit of buffer ClearRegisters zmm0; # Clear the register that will be written into memory Mov rsi, rdi; # Modulus the size of zmm And rsi, 0x3f; Test rsi, rsi; IfNz sub # Need to align so that the rest of the clear can be done in full zmm blocks {Vq(align, rsi)->setMaskFirst(k7); # Set mask bits Vmovdqu8 "[rax]{k7}", zmm0; # Masked move to memory Add rax, rsi; # Update point to clear from Sub rdi, rsi; # Reduce clear length }; For # Clear remaining memory in full zmm blocks {Vmovdqu64 "[rax]", zmm0; } rax, rdx, RegisterSize zmm0; PopR @save; } in => {size => 3, address => 3}; $s->call(@variables); } sub MaskMemory(@) # Write the specified byte into locations in the target mask that correspond to the locations in the source that contain the specified byte. {my (@variables) = @_; # Variables @_ >= 2 or confess; Comment "Clear memory"; my $size = RegisterSize zmm0; my $s = Subroutine {my ($p) = @_; # Parameters PushR my @save = (k6, k7, rax, rdi, rsi, rdx, r8, r9, r10, zmm0, zmm1, zmm2); $$p{source}->setReg(rax); $$p{mask} ->setReg(rdx); $$p{match} ->setReg(rsi); $$p{set} ->setReg(rdi); $$p{size} ->setReg(r8); Lea r9, "[rax+r8]"; # Address of upper limit of source Vpbroadcastb zmm1, rsi; # Character to match Vpbroadcastb zmm2, rdi; # Character to write into mask Mov r10, r8; # Modulus the size of zmm And r10, 0x3f; Test r10, r10; IfNz sub # Need to align so that the rest of the clear can be done in full zmm blocks {Vq(align, r10)->setMaskFirst(k7); # Set mask bits Vmovdqu8 "zmm0\{k7}", "[rax]"; # Load first incomplete block of source Vpcmpub "k6{k7}", zmm0, zmm1, 0; # Characters in source that match Vmovdqu8 "[rdx]{k6}", zmm2; # Write set byte into mask at match points Add rax, r10; # Update point to mask from Add rdx, r10; # Update point to mask to Sub r8, r10; # Reduce mask length }; For # Clear remaining memory in full zmm blocks {Vmovdqu8 zmm0, "[rax]"; # Load complete block of source Vpcmpub "k7", zmm0, zmm1, 0; # Characters in source that match Vmovdqu8 "[rdx]{k7}", zmm2; # Write set byte into mask at match points Add rdx, $size; # Update point to mask to } rax, r9, $size; PopR @save; } in => {size => 3, source => 3, mask => 3, match => 3, set => 3}; # Match is the character to match on in the source, set is the character to write into the mask at the corresponding position. $s->call(@variables); } sub MaskMemoryInRange4(@) # Write the specified byte into locations in the target mask that correspond to the locations in the source that contain 4 bytes in the specified range. {my (@variables) = @_; # Variables @_ >= 6 or confess; Comment "Clear memory"; my $size = RegisterSize zmm0; my $s = Subroutine {my ($p) = @_; # Parameters PushR my @save = (k4, k5, k6, k7, zmm(0..9), map{"r$_"} qw(ax di si dx), 8..15); $$p{source}->setReg(rax); $$p{mask} ->setReg(rdx); $$p{low} ->setReg(r10); $$p{high} ->setReg(r11); $$p{set} ->setReg(rdi); $$p{size} ->setReg(rsi); Vpbroadcastb zmm1, rdi; # Character to write into mask Vpbroadcastb zmm2, r10; # Character 1 low Shr r10, 8; Vpbroadcastb zmm3, r10; # Character 2 low Shr r10, 8; Vpbroadcastb zmm4, r10; # Character 3 low Shr r10, 8; Vpbroadcastb zmm5, r10; # Character 4 low Vpbroadcastb zmm6, r11; # Character 1 high Shr r11, 8; Vpbroadcastb zmm7, r11; # Character 2 high Shr r11, 8; Vpbroadcastb zmm8, r11; # Character 3 high Shr r11, 8; Vpbroadcastb zmm9, r11; # Character 4 high KeepFree r10, r11; Lea r8, "[rax+rsi]"; # Address of upper limit of source my sub check($$) # Check a character {my ($z, $f) = @_; # First zmm, finished label my $Z = $z + 4; Vpcmpub "k6{k7}", zmm0, "zmm$z", 5; # Greater than or equal Vpcmpub "k7{k6}", zmm0, "zmm$Z", 2; # Less than or equal Ktestq k7, k7; Jz $f; # No match Kshiftlq k7, k7, 1; # Match - move up to next character }; my sub last4() # Expand each set bit four times {Kshiftlq k6, k7, 1; Kandq k7, k6, k7; # We have found a character in the specified range Kshiftlq k6, k7, 2; Kandq k7, k6, k7; # Last four }; For # Mask remaining memory in full zmm blocks {my $finished = Label; # Point where we have finished the initial comparisons Vmovdqu8 zmm0, "[rax]"; # Load complete block of source Kxnorq k7, k7, k7; # Complete block - sets register to all ones check($_, $finished) for 2..5; last4; # Check a range Vmovdqu8 "[rdx]{k7}", zmm1; # Write set byte into mask at match points Add rdx, $size; # Update point to mask to SetLabel $finished; } rax, r8, $size; Mov r10, rsi; And r10, 0x3f; # Modulus the size of zmm Test r10, r10; IfNz sub # Need to align so that the rest of the mask can be done in full zmm blocks {my $finished = Label; # Point where we have finished the initial comparisons Vq(align, r10)->setMaskFirst(k7); # Set mask bits Vmovdqu8 "zmm0\{k7}", "[rax]"; # Load first incomplete block of source check($_, $finished) for 2..5; last4; # Check a range Vmovdqu8 "[rdx]{k7}", zmm1; # Write set byte into mask at match points Add rax, r10; # Update point to mask from Add rdx, r10; # Update point to mask to Sub r8, r10; # Reduce mask length SetLabel $finished; }; PopR @save; } in => {size => 3, source => 3, mask => 3, set => 3, low => 3, high => 3}; $s->call(@variables); } # MaskMemoryInRange4 sub CopyMemory(@) # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi {my (@variables) = @_; # Variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Copy memory"; SaveFirstSeven; $$p{source}->setReg(rsi); $$p{target}->setReg(rax); $$p{size} ->setReg(rdi); ClearRegisters rdx; For # Clear memory {Mov "r8b", "[rsi+rdx]"; Mov "[rax+rdx]", "r8b"; } rdx, rdi, 1; RestoreFirstSeven; } in => {source => 3, target => 3, size => 3}; $s->call(@variables); } #D2 Files # Interact with the operating system via files. sub OpenRead() # Open a file, whose name is addressed by rax, for read and return the file descriptor in rax {@_ == 0 or confess; Comment "Open a file for read"; my $sub = Macro {my $S = extractMacroDefinitionsFromCHeaderFile "asm-generic/fcntl.h"; # Constants for reading a file my $O_RDONLY = $$S{O_RDONLY}; SaveFirstFour; Mov rdi,rax; Mov rax,2; Mov rsi,$O_RDONLY; Xor rdx,rdx; Syscall; RestoreFirstFourExceptRax; } name=> "OpenRead"; Call $sub; } sub OpenWrite() # Create the file named by the terminated string addressed by rax for write {@_ == 0 or confess; Comment "Open a file for write"; my $sub = Macro {my $S = extractMacroDefinitionsFromCHeaderFile "fcntl.h"; # Constants for creating a file # my $T = extractMacroDefinitionsFromCHeaderFile "sys/stat.h"; my $O_WRONLY = $$S{O_WRONLY}; my $O_CREAT = $$S{O_CREAT}; my $O_RDWR = $$S{O_RDWR}; # my $S_IRUSR = $$T{__S_IREAD}; # my $S_IWUSR = $$T{__S_IWRITE}; my $write = $O_WRONLY+0 | $O_CREAT+0; SaveFirstFour; # Mov rdi,16; Mov rdi, rax; Mov rax, 2; Mov rsi, $write; # ClearRegisters rdx; Mov rdx, 0x1c0; # u=rwx 1o=x 4o=r 8g=x 10g=w 20g=r 40u=x 80u=r 100u=r 200=T 400g=S 800u=S #0,2,1000, nothing Syscall; RestoreFirstFourExceptRax; } name=> "OpenWrite"; Call $sub; } sub CloseFile() # Close the file whose descriptor is in rax {@_ == 0 or confess; my $sub = Macro {Comment "Close a file"; SaveFirstFour; Mov rdi, rax; Mov rax, 3; Syscall; RestoreFirstFourExceptRax; } name=> "CloseFile"; Call $sub; } sub StatSize() # Stat a file whose name is addressed by rax to get its size in rax {@_ == 0 or confess; my $S = extractCStructure "#include "; # Get location of size field my $Size = $$S{stat}{size}; my $off = $$S{stat}{fields}{st_size}{loc}; my $sub = Macro {Comment "Stat a file for size"; SaveFirstFour rax; Mov rdi, rax; # File name KeepFree rax; Mov rax,4; Lea rsi, "[rsp-$Size]"; Syscall; KeepFree rax; Mov rax, "[$off+rsp-$Size]"; # Place size in rax RestoreFirstFourExceptRax; } name=> "StatSize"; Call $sub; } sub ReadFile(@) # Read a file whose name is addressed by rax into memory. The address of the mapped memory and its length are returned in registers rax,rdi {my (@variables) = @_; # Variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; Comment "Read a file into memory"; SaveFirstSeven; # Generated code my ($local, $file, $addr, $size, $fdes) = AllocateAll8OnStack 4; # Local data $$p{file}->setReg(rax); # File name StatSize; # File size Mov $size, rax; # Save file size KeepFree rax; $$p{file}->setReg(rax); # File name OpenRead; # Open file for read Mov $fdes, rax; # Save file descriptor KeepFree rax; my $d = extractMacroDefinitionsFromCHeaderFile "linux/mman.h"; # mmap constants my $pa = $$d{MAP_PRIVATE}; my $ro = $$d{PROT_READ}; Mov rax, 9; # mmap Mov rsi, $size; # Amount of memory Xor rdi, rdi; # Anywhere Mov rdx, $ro; # Read write protections Mov r10, $pa; # Private and anonymous map Mov r8, $fdes; # File descriptor for file backing memory Mov r9, 0; # Offset into file Syscall; Mov rdi, $size; $local->free; # Free stack frame $$p{address}->getReg(rax); $$p{size} ->getReg(rdi); RestoreFirstSeven; } in => {file => 3}, out => {address => 3, size => 3}; $s->call(@variables); } sub executeFileViaBash(@) # Execute the file named in the byte string addressed by rax with bash {my (@variables) = @_; # Variables @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Execute a file via bash"; SaveFirstFour; Fork; # Fork Test rax, rax; IfNz # Parent {WaitPid; } sub # Child {KeepFree rax; $$p{file}->setReg(rdi); Mov rsi, 0; Mov rdx, 0; Mov rax, 59; Syscall; }; RestoreFirstFour; } in => {file => 3}; $s->call(@variables); } sub unlinkFile(@) # Unlink the named file {my (@variables) = @_; # Variables @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Unlink a file"; SaveFirstFour; $$p{file}->setReg(rdi); Mov rax, 87; Syscall; RestoreFirstFour; } in => {file => 3}; $s->call(@variables); } #D1 Hash functions # Hash functions sub Hash() # Hash a string addressed by rax with length held in rdi and return the hash code in r15 {@_ == 0 or confess; my $sub = Macro # Read file {Comment "Hash"; PushR my @regs = (rax, rdi, k1, zmm0, zmm1); # Save registers PushR r15; Vpbroadcastq zmm0, rdi; # Broadcast length through ymm0 Vcvtuqq2pd zmm0, zmm0; # Convert to lengths to float Vgetmantps zmm0, zmm0, 4; # Normalize to 1 to 2, see: https://hjlebbink.github.io/x86doc/html/VGETMANTPD.html Add rdi, rax; # Upper limit of string ForIn # Hash in ymm0 sized blocks {Vmovdqu ymm1, "[rax]"; # Load data to hash Vcvtudq2pd zmm1, ymm1; # Convert to float Vgetmantps zmm0, zmm0, 4; # Normalize to 1 to 2, see: https://hjlebbink.github.io/x86doc/html/VGETMANTPD.html Vmulpd zmm0, zmm1, zmm0; # Multiply current hash by data } sub # Remainder in partial block {Mov r15, -1; Bzhi r15, r15, rdi; # Clear bits that we do not wish to load Kmovq k1, r15; # Take up mask Vmovdqu8 "ymm1{k1}", "[rax]"; # Load data to hash KeepFree r15; Vcvtudq2pd zmm1, ymm1; # Convert to float Vgetmantps zmm0, zmm0, 4; # Normalize to 1 to 2, see: https://hjlebbink.github.io/x86doc/html/VGETMANTPD.html Vmulpd zmm0, zmm1, zmm0; # Multiply current hash by data }, rax, rdi, RegisterSize ymm0; Vgetmantps zmm0, zmm0, 4; # Normalize to 1 to 2, see: https://hjlebbink.github.io/x86doc/html/VGETMANTPD.html Mov r15, 0b11110000; # Top 4 to bottom 4 Kmovq k1, r15; Vpcompressq "zmm1{k1}", zmm0; Vaddpd ymm0, ymm0, ymm1; # Top 4 plus bottom 4 KeepFree r15; Mov r15, 0b1100; # Top 2 to bottom 2 Kmovq k1, r15; Vpcompressq "ymm1{k1}", ymm0; Vaddpd xmm0, xmm0, xmm1; # Top 2 plus bottom 2 KeepFree r15; Pslldq xmm0, 2; # Move centers into double words Psrldq xmm0, 4; Mov r15, 0b0101; # Centers to lower quad Kmovq k1, r15; Vpcompressd "xmm0{k1}", xmm0; # Compress to lower quad PopR r15; Vmovq r15, xmm0; # Result in r15 PopR @regs; } name=> "Hash"; Call $sub; } #D1 Unicode # Convert utf8 to utf32 sub GetNextUtf8CharAsUtf32(@) # Get the next utf8 encoded character from the addressed memory and return it as a utf32 char {my (@parameters) = @_; # Parameters @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Get next Utf8 char"; PushR my @save = (r11, r12, r13, r14, r15); $$p{fail}->getConst(0); # Clear failure indicator $$p{in}->setReg(r15); # Character to convert ClearRegisters r14; # Move to byte register below does not clear the entire register KeepFree r14; Mov r14b, "[r15]"; my $success = Label; # https://en.wikipedia.org/wiki/UTF-8 KeepFree r15; Cmp r14, 0x7f; # Ascii IfLe {$$p{out}->getReg(r14); $$p{size}->copy(Cq(one, 1)); Jmp $success; KeepFree rax, r11, r12, r13, r14, r15; }; Cmp r14, 0xdf; # 2 bytes IfLe {Mov r13b, "[r15+1]"; And r13, 0x3f; And r14, 0x1f; Shl r14, 6; Or r14, r13; $$p{out}->getReg(r14); $$p{size}->copy(Cq(two, 2)); Jmp $success; KeepFree rax, r11, r12, r13, r14, r15; }; Cmp r14, 0xef; # 3 bytes IfLe {Mov r12b, "[r15+2]"; And r12, 0x3f; Mov r13b, "[r15+1]"; And r13, 0x3f; And r14, 0x0f; Shl r13, 6; Shl r14, 12; Or r14, r13; Or r14, r12; $$p{out}->getReg(r14); $$p{size}->copy(Cq(three, 3)); Jmp $success; KeepFree rax, r11, r12, r13, r14, r15; }; Cmp r14, 0xf7; # 4 bytes IfLe {Mov r11b, "[r15+3]"; And r11, 0x3f; Mov r12b, "[r15+2]"; And r12, 0x3f; Mov r13b, "[r15+1]"; And r13, 0x3f; And r14, 0x07; Shl r12, 6; Shl r13, 12; Shl r14, 18; Or r14, r13; Or r14, r12; Or r14, r11; $$p{out}->getReg(r14); $$p{size}->copy(Cq(four, 4)); Jmp $success; KeepFree rax, r11, r12, r13, r14, r15; }; $$p{fail}->getConst(1); # Conversion failed SetLabel $success; PopR @save; } in => {in => 3}, out => {out => 3, size => 3, fail => 3}; $s->call(@parameters); } # GetNextUtf8CharAsUtf32 sub ConvertUtf8ToUtf32(@) # Convert a string of utf8 to an allocated block of utf32 and return its address and length. {my (@parameters) = @_; # Parameters @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Convert utf8 to utf32"; PushR my @save = (r10, r11, r12, r13, r14, r15); my $size = $$p{size8} * 4; # Estimated length for utf32 AllocateMemory size => $size, my $address = Vq(address); $$p{u8} ->setReg(r14); # Current position in input string ($$p{u8}+$$p{size8})->setReg(r15); # Upper limit of input string $address->setReg(r13); # Current position in output string ClearRegisters r12; # Number of characters in output string ForEver sub # Loop through input string converting each utf8 sequence to utf32 {my ($start, $end) = @_; my @p = my ($out, $size, $fail) = (Vq(out), Vq(size), Vq('fail')); GetNextUtf8CharAsUtf32 Vq(in, r14), @p; # Get next utf 8 character and convert it to utf32 If ($fail, sub {PrintErrStringNL "Invalid utf8 character at index:"; PrintErrRegisterInHex r12; Exit(1); }); Inc r12; # Count characters converted $out->setReg(r11); # Output character Mov "[r13]", r11d; Add r13, RegisterSize eax; # Move up 32 bits output string $size->setReg(r10); # Decoded this many bytes Add r14, r10; # Move up in input string Cmp r14, r15; IfGe {Jmp $end}; # Exhausted input string }; $$p{u32} ->copy($address); # Address of allocation $$p{size32}->copy($size); # Size of allocation $$p{count} ->getReg(r12); # Number of unicode points converted from utf8 to utf32 PopR @save; } in => {u8 => 3, size8 => 3}, out => {u32 => 3, size32 => 3, count => 3}; $s->call(@parameters); } # ConvertUtf8ToUtf32 sub ClassifyCharacters4(@) # Classify the utf32 characters in a block of memory of specified length using the classification held in zmm0: zmm0 should be formatted in double words with each word having the classification in the highest 8 bits and the utf32 character so classified in the lower 21 bits. The classification bits are copied into the high unused) byte of each utf32 character in the block of memory. {my (@parameters) = @_; # Parameters @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Classify characters in utf32 format"; my $finish = Label; PushR my @save = (r14, r15, k6, k7, zmm 29..31); Mov r15, 0x88888888; # Create a mask for the classification bytes Kmovq k7, r15; KeepFree r15; Kshiftlq k6, k7, 32; # Move mask into upper half of register Korq k7, k6, k7; # Classification bytes masked by k7 Knotq k7, k7; # Utf32 characters mask Vmovdqu8 "zmm31\{k7}{z}", zmm0; # utf32 characters to match $$p{address}->setReg(r15); # Address of first utf32 character $$p{size}->for(sub # Process each utf32 character in the block of memory {my ($index, $start, $next, $end) = @_; Mov r14d, "[r15]"; # Load utf32 character Add r15, RegisterSize r14d; # Move up to next utf32 character Vpbroadcastd zmm30, r14d; # 16 copies of the utf32 character to be processed Vpcmpud k7, zmm30, zmm31, 0; # Look for one matching character Ktestw k7, k7; # Was there a match IfZ {Jmp $next}; # No character was matched Vpcompressd "zmm30\{k7}", zmm0; # Place classification byte at start of xmm Vpextrb "[r15-1]", xmm30, 3; # Extract classification character }); SetLabel $finish; PopR @save; } in => {address => 3, size => 3}; $s->call(@parameters); } # ClassifyCharacters4 sub ClassifyRange($@) #P Implementation of ClassifyInRange and ClassifyWithinRange {my ($recordOffsetInRange, @parameters) = @_; # Record offset in classification in high byte if 1 else in classification if 2, parameters @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Classify characters in utf32 format"; my $finish = Label; PushR my @save = (($recordOffsetInRange ? (r12, r13) : ()), # More registers required if we are recording position in range r14, r15, k6, k7, zmm 29..31); Mov r15, 0x88888888; # Create a mask for the classification bytes Kmovq k7, r15; KeepFree r15; Kshiftlq k6, k7, 32; # Move mask into upper half of register Korq k7, k6, k7; # Classification bytes masked by k7 Knotq k7, k7; # Utf32 characters mask Vmovdqu8 "zmm31\{k7}{z}", zmm1; # utf32 characters at upper end of each range Vmovdqu8 "zmm30\{k7}{z}", zmm0; # utf32 characters at lower end of each range $$p{address}->setReg(r15); # Address of first utf32 character $$p{size}->for(sub # Process each utf32 character in the block of memory {my ($index, $start, $next, $end) = @_; Mov r14d, "[r15]"; # Load utf32 character Add r15, RegisterSize r14d; # Move up to next utf32 character Vpbroadcastd zmm29, r14d; # 16 copies of the utf32 character to be processed Vpcmpud k7, zmm29, zmm30, 5; # Look for start of range Vpcmpud "k6\{k7}", zmm29, zmm31, 2; # Look for end of range Ktestw k6, k6; # Was there a match ? IfZ {Jmp $next}; # No character was matched # Process matched character if ($recordOffsetInRange == 1) # Record offset in classification range in high byte as used for bracket matching {Vpcompressd "zmm29\{k6}", zmm0; # Place classification byte at start of xmm29 Vpextrd r13d, xmm29, 4; # Extract start of range Mov r12, r13; # Copy start of range Shr r12, 24; # Classification start And r13, 0x00ffffff; # Range start Sub r14, r13; # Offset in range Add r12, r14; # Offset in classification Mov "[r15-1]", r12b; # Save classification } elsif ($recordOffsetInRange == 2) # Record classification in high byte and offset in classification range in low byte as used for alphabets {Vpcompressd "zmm29\{k6}", zmm0; # Place classification byte and start of range at start of xmm29 Vpextrd r13d, xmm29, 4; # Extract start of range specification Mov r12, r13; # Range classification code and start of range Shr r12, 24; # Range classification code Mov "[r15-1]", r12b; # Save classification And r13, 0x00ffffff; # Range start Vpcompressd "zmm29\{k6}", zmm1; # Place start of alphabet at start of xmm29 Vpextrd r12d, xmm29, 4; # Extract offset of alphabet in range Shr r12, 24; # Alphabet offset Add r12, r14; # Range start plus utf32 Sub r12, r13; # Offset of utf32 in alphabet range Mov "[r15-4]", r12b; # Save offset of utf32 in alphabet range KeepFree r12; ClearRegisters r12; # Zero r12 Mov "[r15-3]", r12w; # Clear middle of utf32 } else # Record classification in high byte {Vpcompressd "zmm29\{k6}", zmm0; # Place classification byte at start of xmm29 Vpextrb "[r15-1]", xmm29, 3; # Extract and save classification } }); SetLabel $finish; PopR @save; } name => "ClassifyRange_$recordOffsetInRange", in => {address => 3, size => 3}; $s->call(@parameters); } # ClassifyRange sub ClassifyInRange(@) # Character classification: classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with each word in zmm1 having the classification in the highest 8 bits and with zmm0 and zmm1 having the utf32 character at the start (zmm0) and end (zmm1) of each range in the lower 21 bits. The classification bits from the first matching range are copied into the high (unused) byte of each utf32 character in the block of memory. {my (@parameters) = @_; # Parameters ClassifyRange(0, @_); } sub ClassifyWithInRange(@) # Bracket classification: Classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with the classification range in the highest 8 bits of zmm0 and zmm1 and the utf32 character at the start (zmm0) and end (zmm1) of each range in the lower 21 bits. The classification bits from the position within the first matching range are copied into the high (unused) byte of each utf32 character in the block of memory. {my (@parameters) = @_; # Parameters ClassifyRange(1, @_); } sub ClassifyWithInRangeAndSaveOffset(@) # Alphabetic classification: classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with the classification code in the high byte of zmm1 and the offset of the first element in the range in the high byte of zmm0. The lowest 21 bits of each double word in zmm0 and zmm1 contain the utf32 characters marking the start and end of each range. The classification bits from zmm1 for the first matching range are copied into the high byte of each utf32 character in the block of memory. The offset in the range is copied into the lowest byte of each utf32 character in the block of memory. The middle two bytes are cleared. The net effect is to reduce 21 bits of utf32 to 16 bits. {my (@parameters) = @_; # Parameters ClassifyRange(2, @_); } sub MatchBrackets(@) # Replace the low three bytes of a utf32 bracket character with 24 bits of offset to the matching opening or closing bracket. Opening brackets have even codes from 0x10 to 0x4e while the corresponding closing bracket has a code one higher. {my (@parameters) = @_; # Parameters @_ >= 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Match brackets in utf 32 text"; my $finish = Label; PushR my @save = (xmm0, k7, r10, r11, r12, r13, r14, r15, rbp); # r15 current character address. r14 is the current classification. r13 the last classification code. r12 the stack depth. r11 the number of opening brackets found. r10 address of first utf32 character. Mov rbp, rsp; # Save stack location so we can use the stack to record the brackets we have found ClearRegisters r11, r12, r15; # Count the number of brackets and track the stack depth, index of each character Cq(three, 3)->setMaskFirst(k7); # These are the number of bytes that we are going to use for the offsets of brackets which limits the size of a program to 24 million utf32 characters $$p{fail} ->getConst(0); # Clear failure indicator $$p{opens} ->getConst(0); # Clear count of opens $$p{address}->setReg(r10); # Address of first utf32 character my $w = RegisterSize eax; # Size of a utf32 character $$p{size}->for(sub # Process each utf32 character in the block of memory {my ($index, $start, $next, $end) = @_; my $continue = Label; Mov r14b, "[r10+$w*r15+3]"; # Classification character Cmp r14, 0x10; # First bracket IfLt sub {Jmp $continue}; # Less than first bracket Cmp r14, 0x4f; # Last bracket IfGt sub {Jmp $continue}; # Greater than last bracket Test r14, 1; # Zero means that the bracket is an opener IfZ sub # Save an opener then continue {Push r15; # Save position in input Push r14; # Save opening code Inc r11; # Count number of opening brackets Inc r12; # Number of brackets currently open Jmp $continue; }; Cmp r12, 1; # Check that there is a bracket to match on the stack IfLt sub # Nothing on stack {Not r15; # Minus the offset at which the error occurred so that we can fail at zero $$p{fail}->getReg(r15); # Position in input that caused the failure Jmp $finish; # Return }; Mov r13, "[rsp]"; # Peek at the opening bracket code which is on top of the stack Inc r13; # Expected closing bracket Cmp r13, r14; # Check for match IfNe sub # Mismatch {Not r15; # Minus the offset at which the error occurred so that we can fail at zero $$p{fail}->getReg(r15); # Position in input that caused the failure Jmp $finish; # Return }; Pop r13; # The closing bracket matches the opening bracket Pop r13; # Offset of opener Dec r12; # Close off bracket sequence Vpbroadcastq xmm0, r15; # Load offset of opener Vmovdqu8 "[r10+$w*r13]\{k7}", xmm0; # Save offset of opener in the code for the closer - the classification is left intact so we still know what kind of bracket we have Vpbroadcastq xmm0, r13; # Load offset of opener Vmovdqu8 "[r10+$w*r15]\{k7}", xmm0; # Save offset of closer in the code for the openercloser - the classification is left intact so we still know what kind of bracket we have SetLabel $continue; # Continue with next character Inc r15; # Next character }); SetLabel $finish; Mov rsp, rbp; # Restore stack $$p{opens}->getReg(r11); # Number of brackets opened PopR @save; } in => {address => 3, size => 3}, out => {fail => 3, opens => 3}; $s->call(@parameters); } # MatchBrackets sub PrintUtf32($$) # Print the specified number of utf32 characters at the specified address {my ($n, $m) = @_; # Variable: number of characters to print, variable: address of memory PushR my @save = (rax, r14, r15); my $count = $n / 2; my $count1 = $count - 1; $count->for(sub {my ($index, $start, $next, $end) = @_; my $a = $m + $index * 8; $a->setReg(rax); KeepFree rax; Mov rax, "[rax]"; KeepFree rax; Mov r14, rax; Mov r15, rax; Shl r15, 32; Shr r14, 32; Or r14,r15; Mov rax, r14; PrintOutRaxInHex; If ($index % 8 == 7, sub # {PrintOutNL; # }, sub {If($index != $count1, sub {PrintOutString " "; }); }); }); PrintOutNL; PopR @save; } #D1 Short Strings # Operations on Short Strings sub LoadShortStringFromMemoryToZmm2($) # Load the short string addressed by rax into the zmm register with the specified number {my ($zmm) = @_; # Zmm register to load @_ == 1 or confess; my $sub = Macro {Comment "Load a short string from memory into zmm$zmm"; PushR rax; Mov r15b, "[rax]"; # Load first byte which is the length of the string Inc r15; # Length field Mov r14, -1; # Clear bits that we do not wish to load Bzhi r14, r14, r15; Kmovq k1, r14; Vmovdqu8 "zmm${zmm}{k1}", "[rax]"; # Load string PopR rax; } name=> "LoadShortStringFromMemoryTozmm$zmm"; Call $sub; } sub LoadShortStringFromMemoryToZmm($$) # Load the short string addressed by rax into the zmm register with the specified number {my ($zmm, $address) = @_; # Zmm register to load, address of string in memory @_ == 2 or confess; Comment "Load a short string from memory into zmm$zmm from $address"; PushR my @save = (r15, r14, k7); # Use these registers Mov r15b, "[$address]"; # Load first byte which is the length of the string Inc r15; # Length field Mov r14, -1; # Clear bits that we do not wish to load Bzhi r14, r14, r15; Kmovq k7, r14; Vmovdqu8 "zmm${zmm}{k7}", "[$address]"; # Load string PopR @save; } sub GetLengthOfShortString($$) # Get the length of the short string held in the numbered zmm register into the specified register {my ($reg, $zmm) = @_; # Register to hold length, number of zmm register containing string @_ == 2 or confess; Pextrb $reg, "xmm$zmm", 0; # Length Keep $reg # Result register } sub SetLengthOfShortString($$) # Set the length of the short string held in the numbered zmm register into the specified register {my ($zmm, $reg) = @_; # Number of zmm register containing string, register to hold length @_ == 2 or confess; RegisterSize $reg == 1 or confess "Use a byte register"; # Nasm thinks that PinsrB requires a byte register Pinsrb "xmm$zmm", $reg, 0; # Set length $reg # Input register } sub ConcatenateShortStrings($$) # Concatenate the numbered source zmm containing a short string with the short string in the numbered target zmm. {my ($left, $right) = @_; # Target zmm, source zmm @_ == 2 or confess; my $sub = Macro # Read file {Comment "Concatenate the short string in zmm$right to the short string in zmm$left"; PushR my @save = (k7, rcx, r14, r15); GetLengthOfShortString r15, $right; # Right length Mov r14, -1; # Expand mask Bzhi r14, r14, r15; # Skip bits for left GetLengthOfShortString rcx, $left; # Left length Inc rcx; # Skip length Shl r14, cl; # Skip length Kmovq k7, r14; # Unload mask PushR "zmm${right}"; # Stack right Sub rsp, rcx; # Position for masked read Vmovdqu8 "zmm${left}{k7}", "[rsp+1]"; # Load right string Add rsp, rcx; # Restore stack Add rsp, RegisterSize zmm0; Dec rcx; # Length of left Add rcx, r15; # Length of combined string = length of left plus length of right Pinsrb "xmm${left}", cl, 0; # Save length in result PopR @save; } name=> "ConcatenateShortStrings${left}and${right}"; Call $sub; } #D1 Byte Strings # Operations on Byte Strings sub Cstrlen() #P Length of the C style string addressed by rax returning the length in r15 {@_ == 0 or confess; my $sub = Macro # Create byte string {Comment "C strlen"; PushR my @regs = (rax, rdi, rcx); Mov rdi, rax; Mov rcx, -1; ClearRegisters rax; push @text, < "Cstrlen"; Call $sub; } sub StringLength(@) # Length of a zero terminated string {my (@parameters) = @_; # Parameters Comment "Length of zero terminated string"; my $s = Subroutine {my ($p) = @_; # Parameters SaveFirstFour; $$p{string}->setReg(rax); # Address string Cstrlen; # Length now in r15 $$p{size}->getReg(r15); # Save length RestoreFirstFour; } in => {string => 3}, out => {size => 3}; $s->call(@parameters, my $z = Vq(size)); # Variable that holds the length of the string $z } sub CreateByteString(%) # Create an relocatable string of bytes in an arena and returns its address in rax. Optionally add a chain header so that 64 byte blocks of memory can be freed and reused within the byte string. {my (%options) = @_; # free=>1 adds a free chain. Comment "Create byte string"; my $N = Vq(size, 4096); # Initial size of string my ($string, $size, $used, $free) = All8Structure 3; # String base my $data = $string->field(0, "start of data"); # Start of data my $s = Subroutine {my ($p) = @_; # Parameters SaveFirstFour; AllocateMemory($N, address=>$$p{bs}); # Allocate memory and save its location in a variable $$p{bs}->setReg(rax); $N ->setReg(rdx); Mov rdi, $string->size; # Size of byte string base structure which is constant Mov $used->addr, rdi; # Used space Mov $size->addr, rdx; # Size RestoreFirstFour; } out => {bs => 3}; $s->call(my $bs = Vq(bs)); # Variable that holds the reference to the byte string genHash(__PACKAGE__."::ByteString", # Definition of byte string structure => $string, # Structure details size => $size, # Size field details used => $used, # Used field details free => $free, # Free chain offset data => $data, # The start of the data bs => $bs, # Variable that addresses the byte string ); } sub Nasm::X86::ByteString::chain($$$@) # Return a variable with the end point of a chain of double words in the byte string starting at the specified variable. {my ($byteString, $bs, $variable, @offsets) = @_; # Byte string descriptor, byte string locator, start variable, offsets chain @_ >= 3 or confess; PushR my @save = (r14, r15); # 14 is the byte string address, 15 the current offset in the byte string $bs->setReg(r14); $variable->setReg(r15); for my $o(@offsets) # Each offset {KeepFree r15; Mov r15d, "dword[r14+r15+$o]"; # Step through each offset } my $r = Vq(join (' ', @offsets), r15); # Create a variable with the result PopR @save; $r } sub Nasm::X86::ByteString::putChain($$$$@) # Write the double word in the specified variable to the double word location at the the specified offset in the specified byte string. {my ($byteString, $bs, $start, $value, @offsets) = @_; # Byte string descriptor, byte string locator variable, start variable, value to put as a variable, offsets chain @_ >= 5 or confess; PushR my @save = (r14, r15); # 14 is the byte string address, 15 the current offset in the byte string $bs->setReg(r14); $start->setReg(r15); for my $i(keys @offsets) # Each offset {my $o = $offsets[$i]; KeepFree r15; if ($i < $#offsets) # Step through each offset {Mov r15d, "dword[r14+r15+$o]"; } else # Address last location {Lea r15, "[r14+r15+$o]"; } } KeepFree r14; $value->setReg(r14); Mov "[r15]", r14d; PopR @save; } sub Nasm::X86::ByteString::length($@) # Get the length of a byte string {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 2 or confess; my $size = $byteString->size->addr; my $used = $byteString->used->addr; my $s = Subroutine # Allocate more space if required {my ($p) = @_; # Parameters Comment "Byte string length"; SaveFirstFour; $$p{bs}->setReg(rax); # Address byte string Mov rdx, $byteString->used->addr; # Used Sub rdx, $byteString->structure->size; $$p{size}->getReg(rdx); RestoreFirstFour; } in => {bs=>3}, out => {size => 3}; $s->call($byteString->bs, @variables); } sub Nasm::X86::ByteString::updateSpace($@) #P Make sure that the byte string addressed by rax has enough space to accommodate content of length rdi {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 3 or confess; my $size = $byteString->size->addr; my $used = $byteString->used->addr; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Allocate more space for a byte string"; SaveFirstFour; $$p{bs}->setReg(rax); # Address byte string my $oldSize = Vq(oldSize, $size); # Size my $oldUsed = Vq(oldUsed, $used); # Used my $minSize = $oldUsed + $$p{size}; # Minimum size of new string KeepFree rax; If ($minSize > $oldSize, sub # More space needed {Mov rax, 4096; # Minimum byte string size $minSize->setReg(rdx); ForEver {my ($start, $end) = @_; Shl rax, 1; # New byte string size - double the size of the old byte string Cmp rax, rdx; # Big enough? IfGe {Jmp $end}; # Big enough! }; my $newSize = Vq(size, rax); # Save new byte string size AllocateMemory(size => $newSize, my $address = Vq(address)); # Create new byte string CopyMemory(target => $address, source => $$p{bs}, size => $oldUsed); # Copy old byte string into new byte string FreeMemory(address => $$p{bs}, size => $oldSize); # Free previous memory previously occupied byte string $$p{bs}->copy($address); # Save new byte string address }); RestoreFirstFour; } io => {bs=>3}, in=>{size => 3}; $s->call(@variables); } # updateSpace sub Nasm::X86::ByteString::makeReadOnly($) # Make a byte string read only {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Make a byte string readable"; SaveFirstFour; $$p{bs}->setReg(rax); Mov rdi, rax; # Address of byte string Mov rsi, $byteString->size->addr; # Size of byte string KeepFree rax; Mov rdx, 1; # Read only access Mov rax, 10; Syscall; RestoreFirstFour; # Return the possibly expanded byte string } in => {bs => 3}; $s->call(bs => $byteString->bs); } sub Nasm::X86::ByteString::makeWriteable($) # Make a byte string writable {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Make a byte string writable"; SaveFirstFour; $$p{bs}->setReg(rax); Mov rdi, rax; # Address of byte string Mov rsi, $byteString->size->addr; # Size of byte string KeepFree rax; Mov rdx, 3; # Read only access Mov rax, 10; Syscall; RestoreFirstFour; # Return the possibly expanded byte string } in => {bs => 3}; $s->call(bs => $byteString->bs); } sub Nasm::X86::ByteString::allocate($@) # Allocate the amount of space indicated in rdi in the byte string addressed by rax and return the offset of the allocation in the arena in rdi {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Allocate space in a byte string"; SaveFirstFour; $byteString->updateSpace($$p{bs}, $$p{size}); # Update space if needed $$p{bs} ->setReg(rax); Mov rsi, $byteString->used->addr; # Currently used $$p{offset}->getReg(rsi); $$p{size} ->setReg(rdi); Add rsi, rdi; Mov $byteString->used->addr, rsi; # Currently used KeepFree rax, rdi, rsi; RestoreFirstFour; } in => {bs => 3, size => 3}, out => {offset => 3}; $s->call($byteString->bs, @variables); } sub Nasm::X86::ByteString::blockSize($) # Size of a block {my ($byteString) = @_; # Byte string RegisterSize(zmm0) } sub Nasm::X86::ByteString::allocZmmBlock($@) # Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable {my ($byteString, @variables) = @_; # Byte string, variables @_ >= 2 or confess; my $ffb = $byteString->firstFreeBlock; # Check for a free block If ($ffb > 0, sub # Free block available {PushR zmm31; $byteString->getBlock($byteString->bs, $ffb, 31); # Load the first block on the free chain my $second = getDFromZmm(31, 60); # The location of the next pointer is forced upon us by block string which got there first. $byteString->setFirstFreeBlock($second); # Set the first free block field to point to the second block for my $v(@variables) {if (ref($v) and $v->name eq "offset") {$v->copy($ffb); last; } } PopR zmm31; }, sub {$byteString->allocate(Vq(size, RegisterSize(zmm0)), @variables); }); } sub Nasm::X86::ByteString::allocBlock($) # Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable {my ($byteString) = @_; # Byte string @_ == 1 or confess; $byteString->allocZmmBlock # Allocate a zmm block ($byteString->bs, Vq(size, RegisterSize(zmm0)), my $o = Vq(offset)); $o # Offset as a variable } sub Nasm::X86::ByteString::firstFreeBlock($) #P Create and load a variable with the first free block on the free block chain or zero if no such block in the given byte string {my ($byteString) = @_; # Byte string address as a variable @_ == 1 or confess; Comment "Get first free block in a byte string"; PushR rax; $byteString->bs->setReg(rax); #P Address underlying byte string KeepFree rax; Mov rax, $byteString->free->addr; # Content of free chain pointer my $v = Vq('free', rax); # Remainder of the free chain PopR rax; $v } sub Nasm::X86::ByteString::setFirstFreeBlock($$) #P Set the first free block field from a variable {my ($byteString, $offset) = @_; # Byte string descriptor, first free block offset as a variable @_ == 2 or confess; Comment "Set first free block"; PushR my @save = (rax, rsi, rdx); $byteString->bs->setReg(rax); # Address underlying byte string Lea rdx, $byteString->free->addr; # Address of address of free chain $offset->setReg(rsi); # Offset of block being freed Mov "[rdx]", rsi; # Set head of free chain to point to block just freed PopR @save; } sub Nasm::X86::ByteString::freeBlock($@) # Free a block in a byte string by placing it on the free chain {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Free a block in a byte string"; PushR zmm31; my $rfc = $byteString->firstFreeBlock; # Get first free block ClearRegisters zmm31; # Second block $rfc->putDIntoZmm(31, 60); # The position of the next pointer was dictated by block strings. $byteString->putBlock($$p{bs}, $$p{offset}, 31); # Link the freed block to the rest of the free chain $byteString->setFirstFreeBlock($$p{offset}); # Set free chain field to point to latest free chain element PopR zmm31; } in => {bs => 3, offset => 3}; $s->call($byteString->bs, @variables); } sub Nasm::X86::ByteString::getBlock($$$$) # Get the block with the specified offset in the specified block string and return it in the numbered zmm {my ($byteString, $bsa, $block, $zmm) = @_; # Byte string descriptor, byte string variable, offset of the block as a variable, number of zmm register to contain block @_ == 4 or confess; PushR my @save = (r14, r15); # Result register defined($bsa) or confess; $bsa->setReg(r15); # Byte string address defined($block) or confess; If ($block < $byteString->data->loc, sub #DEBUG {PrintErrStringNL "Attempt to get block below start of byte string"; Exit(1); }); $block->setReg(r14); # Offset of block in byte string Vmovdqu64 "zmm$zmm", "[r15+r14]"; # Read from memory PopR @save; # Restore registers } sub Nasm::X86::ByteString::putBlock($$$$) # Write the numbered zmm to the block at the specified offset in the specified byte string {my ($byteString, $bsa, $block, $zmm) = @_; # Byte string descriptor, byte string variable, block in byte string, content variable @_ >= 4 or confess; PushR my @save = (r14, r15); # Work registers defined($bsa) or confess "Byte string not set"; $bsa->setReg(r15); # Byte string address defined($block) or confess; If ($block < $byteString->data->loc, sub #DEBUG {PrintErrStringNL "Attempt to put block below start of byte string"; Exit(1); }); $block->setReg(r14); # Offset of block in byte string Vmovdqu64 "[r15+r14]", "zmm$zmm"; # Write to memory PopR @save; # Restore registers } sub Nasm::X86::ByteString::m($@) # Append the content with length rdi addressed by rsi to the byte string addressed by rax {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 4 or confess; my $used = $byteString->used->addr; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Append memory to a byte string"; SaveFirstFour; $$p{bs}->setReg(rax); my $oldUsed = Vq("used", $used); $byteString->updateSpace($$p{bs}, $$p{size}); # Update space if needed my $target = $oldUsed + $$p{bs}; KeepFree rax; CopyMemory(source => $$p{address}, $$p{size}, target => $target); # Move data in KeepFree rdx; my $newUsed = $oldUsed + $$p{size}; $$p{bs} ->setReg(rax); # Update used field $newUsed->setReg(rdi); Mov $used, rdi; RestoreFirstFour; } io => { bs => 3}, in => {address => 3, size => 3}; $s->call(@variables); } sub Nasm::X86::ByteString::q($$) # Append a constant string to the byte string {my ($byteString, $string) = @_; # Byte string descriptor, string @_ == 2 or confess; my $s = Rs($string); my $bs = $byteString->bs; # Move data my $ad = Vq(address, $s); my $sz = Vq(size, length($string)); $byteString->m($bs, $ad, $sz); } sub Nasm::X86::ByteString::ql($$) # Append a quoted string containing new line characters to the byte string addressed by rax {my ($byteString, $const) = @_; # Byte string, constant @_ == 2 or confess; for my $l(split /\s*\n/, $const) {$byteString->q($l); $byteString->nl; } } sub Nasm::X86::ByteString::char($$) # Append a character expressed as a decimal number to the byte string addressed by rax {my ($byteString, $char) = @_; # Byte string descriptor, number of character to be appended @_ == 2 or confess; my $s = Rb(ord($char)); $byteString->m($byteString->bs, Vq(address, $s), Vq(size, 1)); # Move data } sub Nasm::X86::ByteString::nl($) # Append a new line to the byte string addressed by rax {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; $byteString->char("\n"); } sub Nasm::X86::ByteString::z($) # Append a trailing zero to the byte string addressed by rax {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; $byteString->char("\0"); } sub Nasm::X86::ByteString::append($@) # Append one byte string to another {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Concatenate byte strings"; SaveFirstFour; $$p{source}->setReg(rax); Mov rdi, $byteString->used->addr; Sub rdi, $byteString->structure->size; Lea rsi, $byteString->data->addr; $byteString->m(bs=>$$p{target}, Vq(address, rsi), Vq(size, rdi)); RestoreFirstFour; } in => {target=>3, source=>3}; $s->call(target=>$byteString->bs, @variables); } sub Nasm::X86::ByteString::clear($) # Clear the byte string addressed by rax {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Clear byte string"; PushR my @save = (rax, rdi); $$p{bs}->setReg(rax); Mov rdi, $byteString->structure->size; Mov $byteString->used->addr, rdi; PopR @save; } in => {bs => 3}; $s->call(bs => $byteString->bs); } sub Nasm::X86::ByteString::write($@) # Write the content in a byte string addressed by rax to a temporary file and replace the byte string content with the name of the temporary file {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Write a byte string to a file"; SaveFirstFour; $$p{file}->setReg(rax); OpenWrite; # Open file my $file = Vq('fd', rax); # File descriptor KeepFree rax; $$p{bs}->setReg(rax); # Write file Lea rsi, $byteString->data->addr; Mov rdx, $byteString->used->addr; Sub rdx, $byteString->structure->size; KeepFree rax; Mov rax, 1; # Write content to file $file->setReg(rdi); Syscall; KeepFree rax, rdi, rsi, rdx; $file->setReg(rax); CloseFile; RestoreFirstFour; } in => {bs => 3, file => 3}; $s->call(bs => $byteString->bs, @variables); } sub Nasm::X86::ByteString::read($@) # Read the named file (terminated with a zero byte) and place it into the named byte string. {my ($byteString, @variables) = @_; # Byte string descriptor, variables @_ >= 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Read a byte string"; ReadFile($$p{file}, (my $size = Vq(size)), my $address = Vq(address)); $byteString->m($$p{bs}, $size, $address); # Move data into byte string FreeMemory($size, $address); # Free memory allocated by read } io => {bs => 3}, in => {file => 3}; $s->call(bs => $byteString->bs, @variables); } sub Nasm::X86::ByteString::out($) # Print the specified byte string addressed by rax on sysout {my ($byteString) = @_; # Byte string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Write a byte string"; SaveFirstFour; $$p{bs}->setReg(rax); Mov rdi, $byteString->used->addr; # Length to print Sub rdi, $byteString->structure->size; # Length to print Lea rax, $byteString->data->addr; # Address of data field PrintOutMemory; RestoreFirstFour; } in => {bs => 3}; $s->call($byteString->bs); } sub Nasm::X86::ByteString::dump($;$) # Dump details of a byte string {my ($byteString, $depth) = @_; # Byte string descriptor, optional amount of memory to dump @_ == 1 or @_ == 2 or confess; $depth //= 4; # Default depth PushR my @save = (rax, r15); # Get address of byte string $byteString->bs->setReg(rax); Call Macro # Bash string {Comment "Print details of a byte string"; SaveFirstFour; PrintOutStringNL("Byte String"); PushR rax; # Print size Mov rax, $byteString->size->addr; PrintOutString(" Size: "); PrintOutRaxInHex; PrintOutNL; PopR rax; PushR rax; # Print used Mov rax, $byteString->used->addr; PrintOutString(" Used: "); PrintOutRaxInHex; PrintOutNL; PopR rax; Mov rdi, 64; for my $b(0..$depth-1) # Print the requested number of blocks {my $o = sprintf("%04X: ", 64 * $b); PrintOutString($o); PrintOutMemoryInHexNL; Add rax, 64; } RestoreFirstFour; } name => "Nasm::X86::ByteString::dump$depth"; PopR @save; } #D1 Block Strings # Strings made from zmm sized blocks of text sub Nasm::X86::ByteString::CreateBlockString($) # Create a string from a doubly link linked list of 64 byte blocks linked via 4 byte offsets in the byte string addressed by rax and return its descriptor {my ($byteString) = @_; # Byte string description @_ == 1 or confess; my $b = RegisterSize zmm0; # Size of a block == size of a zmm register my $o = RegisterSize eax; # Size of a double word Comment "Allocate a new block string in a byte string"; my $s = genHash(__PACKAGE__."::BlockString", # Block string definition bs => $byteString, # Bytes string definition links => $b - 2 * $o, # Location of links in bytes in zmm next => $b - 1 * $o, # Location of next offset in block in bytes prev => $b - 2 * $o, # Location of prev offset in block in bytes length => $b - 2 * $o - 1, # Maximum length in a block first => Vq('first'), # Variable addressing first block in block string ); my $first = $s->allocBlock; # Allocate first block $s->first->copy($first); # Record offset of first block if (1) # Initialize circular list {my $nn = $s->next; my $pp = $s->prev; PushR my @save = (r14, r15); $byteString->bs->setReg(r15); $first ->setReg(r14); Mov "[r15+r14+$nn]", r14d; Mov "[r15+r14+$pp]", r14d; PopR @save; } $s # Description of block string } sub Nasm::X86::BlockString::address($) # Address of a block string {my ($blockString) = @_; # Block string descriptor @_ == 1 or confess; $blockString->bs->bs; } sub Nasm::X86::BlockString::allocBlock($) # Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable {my ($blockString) = @_; # Block string descriptor @_ == 1 or confess; $blockString->bs->allocBlock; # Allocate block and return its offset as a variable } sub Nasm::X86::BlockString::getBlockLength($$) # Get the block length of the numbered zmm and return it in a variable {my ($blockString, $zmm) = @_; # Block string descriptor, number of zmm register @_ == 2 or confess; getBFromZmm $zmm, 0; # Block length } sub Nasm::X86::BlockString::setBlockLengthInZmm($$$) # Set the block length of the numbered zmm to the specified length {my ($blockString, $length, $zmm) = @_; # Block string descriptor, length as a variable, number of zmm register @_ == 3 or confess; PushR my @save = (r15); # Save work register $length->setReg(r15); # New length $length->putBIntoZmm($zmm, 0); # Insert block length PopR @save; # Length of block is a byte } sub Nasm::X86::BlockString::getBlock($$$$) # Get the block with the specified offset in the specified block string and return it in the numbered zmm {my ($blockString, $bsa, $block, $zmm) = @_; # Block string descriptor, byte string variable, offset of the block as a variable, number of zmm register to contain block @_ >= 4 or confess; $blockString->bs->getBlock($bsa, $block, $zmm); } sub Nasm::X86::BlockString::putBlock($$$$) # Write the numbered zmm to the block at the specified offset in the specified byte string {my ($blockString, $bsa, $block, $zmm) = @_; # Block string descriptor, byte string variable, block in byte string, content variable @_ >= 4 or confess; $blockString->bs->putBlock($bsa, $block, $zmm); } sub Nasm::X86::BlockString::getNextAndPrevBlockOffsetFromZmm($$) # Get the offsets of the next and previous blocks as variables from the specified zmm {my ($blockString, $zmm) = @_; # Block string descriptor, zmm containing block @_ == 2 or confess; my $l = $blockString->links; # Location of links PushR my @regs = (r14, r15); # Work registers my $L = getQFromZmm($zmm, $blockString->links); # Links in one register $L->setReg(r15); # Links Mov r14d, r15d; # Next Shr r15, RegisterSize(r14d) * 8; # Prev my @r = (Vq("Next block offset", r15), Vq("Prev block offset", r14)); # Result PopR @regs; # Free work registers @r; # Return (next, prev) } sub Nasm::X86::BlockString::putNextandPrevBlockOffsetIntoZmm($$$$) # Save next and prev offsets into a zmm representing a block {my ($blockString, $zmm, $next, $prev) = @_; # Block string descriptor, zmm containing block, next offset as a variable, prev offset as a variable @_ == 4 or confess; if ($next and $prev) # Set both previous and next {PushR my @regs = (r14, r15); # Work registers $next->setReg(r14); # Next offset $prev->setReg(r15); # Prev offset Shl r14, RegisterSize(r14d) * 8; # Prev high Or r15, r14; # Links in one register my $l = Vq("Links", r15); # Links as variable $l->putQIntoZmm($zmm, $blockString->links); # Load links into zmm PopR @regs; # Free work registers } elsif ($next) # Set just next {PushR my @regs = (r15); # Work registers $next->setReg(r15); # Next offset my $l = Vq("Links", r15); # Links as variable $l->putDIntoZmm($zmm, $blockString->next); # Load links into zmm PopR @regs; # Free work registers } elsif ($prev) # Set just prev {PushR my @regs = (r15); # Work registers $prev->setReg(r15); # Next offset my $l = Vq("Links", r15); # Links as variable $l->putDIntoZmm($zmm, $blockString->prev); # Load links into zmm PopR @regs; # Free work registers } } sub Nasm::X86::BlockString::dump($) # Dump a block string to sysout {my ($blockString) = @_; # Block string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Dump a block in a block string"; PushR my @save = (zmm31); my $block = $$p{first}; # The first block $blockString->getBlock($$p{bs}, $block, 31); # The first block in zmm31 my $length = $blockString->getBlockLength(31); # Length of block PrintOutStringNL "Block String Dump"; $block ->out("Offset: "); PrintOutString " "; $length->outNL("Length: "); PrintOutRegisterInHex zmm31; # Print block ForEver # Each block in string {my ($start, $end) = @_; # my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current block If ($next == $block, sub{Jmp $end}); # Next block is the first block so we have printed the block string $blockString->getBlock($$p{bs}, $next, 31); # Next block in zmm my $length = $blockString->getBlockLength(31); # Length of block $next ->out("Offset: "); # Print block PrintOutString " "; $length->outNL("Length: "); PrintOutRegisterInHex zmm31; }; PrintOutNL; PopR @save; } in => {bs => 3, first => 3}; $s->call($blockString->address, $blockString->first); } sub Nasm::X86::BlockString::len($$) # Find the length of a block string {my ($blockString, $size) = @_; # Block string descriptor, size variable @_ == 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Length of a block string"; PushR my @save = (zmm31); my $block = $$p{first}; # The first block $blockString->getBlock($$p{bs}, $block, 31); # The first block in zmm31 my $length = $blockString->getBlockLength(31); # Length of block ForEver # Each block in string {my ($start, $end) = @_; # my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current block If ($next == $block, sub{Jmp $end}); # Next block is the first block so we have printed the block string $blockString->getBlock($$p{bs}, $next, 31); # Next block in zmm $length += $blockString->getBlockLength(31); # Add length of block }; $$p{size}->copy($length); PopR @save; } in => {bs => 3, first => 3}, out => {size => 3}; $s->call($blockString->address, $blockString->first, $size); } sub Nasm::X86::BlockString::concatenate($$) # Concatenate two block strings by appending a copy of the source to the target block string. {my ($target, $source) = @_; # Target block string, source block string @_ == 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Concatenate block strings"; PushR my @save = (zmm29, zmm30, zmm31); my $sb = $$p{sBs}; # The byte string underlying the source my $sf = $$p{sFirst}; # The first block in the source my $tb = $$p{tBs}; # The byte string underlying the target my $tf = $$p{tFirst}; # The first block in the target $source->getBlock($sb, $sf, 31); # The first source block $target->getBlock($tb, $tf, 30); # The first target block my ($ts, $tl) = $target->getNextAndPrevBlockOffsetFromZmm(30); # Target second and last $target->getBlock($tb, $tl, 30); # The last target block to which we will append ForEver # Each block in source string {my ($start, $end) = @_; # Start and end labels my $new = $target->allocBlock; # Allocate new block Vmovdqu8 zmm29, zmm31; # Load new target block from source my ($next, $prev) = $target->getNextAndPrevBlockOffsetFromZmm(30); # Linkage from last target block $target->putNextandPrevBlockOffsetIntoZmm(30, $new, $prev); # From last block $target->putNextandPrevBlockOffsetIntoZmm(29, $tf, $tl); # From new block $target->putBlock($tb, $tl, 30); # Put the modified last target block $tl->copy($new); # New last target block $target->putBlock($tb, $tl, 29); # Put the modified new last target block Vmovdqu8 zmm30, zmm29; # Last target block my ($sn, $sp) = $source->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current source block If ($sn == $sf, sub # Last source block {$source->getBlock($tb, $tf, 30); # The first target block $source->putNextandPrevBlockOffsetIntoZmm(30, undef, $new); # Update end of block chain $source->putBlock($tb, $tf, 30); # Save modified first target block Jmp $end }); $source->getBlock($sb, $sn, 31); # Next source block }; PopR @save; } in => {sBs => 3, sFirst => 3, tBs => 3, tFirst => 3}; $s->call(sBs => $source->address, sFirst => $source->first, tBs => $target->address, tFirst => $target->first); } sub Nasm::X86::BlockString::insertChar($@) # Insert a character into a block string {my ($blockString, @variables) = @_; # Block string, variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Insert character into a block string"; PushR my @save = (k7, r14, r15, zmm30, zmm31); my $B = $$p{bs}; # The byte string underlying the block string my $F = $$p{first}; # The first block in block string my $c = $$p{character}; # The character to insert my $P = $$p{position}; # The position in the block string at which we want to insert the character $blockString->getBlock($B, $F, 31); # The first source block my $C = Vq('Current character position', 0); # Current character position my $L = $blockString->getBlockLength(31); # Length of last block my $M = Vq('Block length', $blockString->length); # Maximum length of a block my $One = Vq('One', 1); # Literal one my $current = $F; # Current position in scan of block chain ForEver # Each block in source string {my ($start, $end) = @_; # Start and end labels If ((($P >= $C) & ($P <= $C + $L)), sub # Position is in current block {my $O = $P - $C; # Offset in current block PushRR zmm31; # Stack block $O->setReg(r14); # Offset of character in block $c->setReg(r15); # Character to insert Mov "[rsp+r14]", r15b; # Place character after skipping length field If ($L < $M, sub # Current block has space {($P+1)->setMask($C + $L - $P + 1, k7); # Set mask for reload Vmovdqu8 "zmm31{k7}", "[rsp-1]"; # Reload $blockString->setBlockLengthInZmm($L + 1, 31); # Length of block }, sub # In the current block but no space so split the block {$One->setMask($C + $L - $P + 2, k7); # Set mask for reload Vmovdqu8 "zmm30{k7}", "[rsp+r14-1]"; # Reload $blockString->setBlockLengthInZmm($O, 31); # New shorter length of original block $blockString->setBlockLengthInZmm($L - $O + 1, 30); # Set length of remainder plus inserted char in the new block my $new = $blockString->allocBlock; # Allocate new block my ($next, $prev)=$blockString->getNextAndPrevBlockOffsetFromZmm(31); # Linkage from last block If ($next == $prev, sub # The existing string has one block, add new as the second block {$blockString->putNextandPrevBlockOffsetIntoZmm(31, $new, $new); $blockString->putNextandPrevBlockOffsetIntoZmm(30, $next, $prev); }, sub # The existing string has two or more blocks {$blockString->putNextandPrevBlockOffsetIntoZmm(31, $new, $prev); # From last block $blockString->putNextandPrevBlockOffsetIntoZmm(30, $next, $current);# From new block }); $blockString->putBlock($B, $new, 30); # Save the modified block }); $blockString->putBlock($B, $current, 31); # Save the modified block PopRR zmm31; # Restore stack KeepFree r14, r15; Jmp $end; # Character successfully inserted }); my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current source block If ($next == $F, sub # Last source block {$c->setReg(r15); # Character to insert Push r15; $blockString->append($B, $F, Vq(size, 1), Vq(source, rsp)); # Append character if we go beyond limit Pop r15; Jmp $end; }); $current->copy($next); $blockString->getBlock($B, $current, 31); # Next block $L = $blockString->getBlockLength(31); # Length of block $C += $L; # Current character position at the start of this block }; PopR @save; } in => {bs => 3, first => 3, character => 3, position => 3}; $s->call($blockString->address, first => $blockString->first, @variables) } sub Nasm::X86::BlockString::deleteChar($@) # Delete a character in a block string {my ($blockString, @variables) = @_; # Block string, variables @_ >= 2 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Delete a character in a block string"; PushR my @save = (k7, zmm31); my $B = $$p{bs}; # The byte string underlying the block string my $F = $$p{first}; # The first block in block string my $P = $$p{position}; # The position in the block string at which we want to insert the character $blockString->getBlock($B, $F, 31); # The first source block my $C = Vq('Current character position', 0); # Current character position my $L = $blockString->getBlockLength(31); # Length of last block my $current = $F; # Current position in scan of block chain ForEver # Each block in source string {my ($start, $end) = @_; # Start and end labels If ((($P >= $C) & ($P <= $C + $L)), sub # Position is in current block {my $O = $P - $C; # Offset in current block PushRR zmm31; # Stack block ($O+1)->setMask($L - $O, k7); # Set mask for reload Vmovdqu8 "zmm31{k7}", "[rsp+1]"; # Reload $blockString->setBlockLengthInZmm($L-1, 31); # Length of block $blockString->putBlock($B, $current, 31); # Save the modified block PopRR zmm31; # Stack block Jmp $end; # Character successfully inserted }); my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current source block $blockString->getBlock($B, $next, 31); # Next block $current->copy($next); $L = $blockString->getBlockLength(31); # Length of block $C += $L; # Current character position at the start of this block }; PopR @save; } in => {bs => 3, first => 3, position => 3}; $s->call($blockString->address, first => $blockString->first, @variables) } sub Nasm::X86::BlockString::getCharacter($@) # Get a character from a block string {my ($blockString, @variables) = @_; # Block string, variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters Comment "Get a character from a block string"; PushR my @save = (r15, zmm31); my $B = $$p{bs}; # The byte string underlying the block string my $F = $$p{first}; # The first block in block string my $P = $$p{position}; # The position in the block string at which we want to insert the character $blockString->getBlock($B, $F, 31); # The first source block my $C = Vq('Current character position', 0); # Current character position my $L = $blockString->getBlockLength(31); # Length of last block ForEver # Each block in source string {my ($start, $end) = @_; # Start and end labels If ((($P >= $C) & ($P <= $C + $L)), sub # Position is in current block {my $O = $P - $C; # Offset in current block PushRR zmm31; # Stack block ($O+1) ->setReg(r15); # Character to get KeepFree r15; Mov r15b, "[rsp+r15]"; # Reload $$p{out}->getReg(r15); # Save character PopRR zmm31; # Stack block Jmp $end; # Character successfully inserted }); my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Get links from current source block $blockString->getBlock($B, $next, 31); # Next block $L = $blockString->getBlockLength(31); # Length of block $C += $L; # Current character position at the start of this block }; PopR @save; } in => {bs => 3, first => 3, position => 3}, out => {out => 3}; $s->call($blockString->address, first => $blockString->first, @variables) } sub Nasm::X86::BlockString::append($@) # Append the specified content in memory to the specified block string {my ($blockString, @variables) = @_; # Block string descriptor, variables @_ >= 3 or confess; my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Append completed successfully my $Z = Vq(zero, 0); # Zero my $O = Vq(one, 1); # One my $L = Vq(size, $blockString->length); # Length of a full block my $B = $$p{bs}; # Underlying block string my $source = $$p{source}; # Address of content to be appended my $size = $$p{size}; # Size of content my $first = $$p{first}; # First (preallocated) block in block string PushR my @save = (zmm29, zmm30, zmm31); ForEver # Append content until source exhausted {my ($start, $end) = @_; # Parameters $blockString->getBlock($B, $first, 29); # Get the first block my ($second, $last) = $blockString->getNextAndPrevBlockOffsetFromZmm(29); # Get the offsets of the second and last blocks $blockString->getBlock($B, $last, 31); # Get the last block my $lengthLast = $blockString->getBlockLength(31); # Length of last block my $spaceLast = $L - $lengthLast; # Space in last block my $toCopy = $spaceLast->min($size); # Amount of data required to fill first block my $startPos = $O + $lengthLast; # Start position in zmm $source->setZmm(31, $startPos, $toCopy); # Append bytes $blockString->setBlockLengthInZmm($lengthLast + $toCopy, 31); # Set the length $blockString->putBlock($B, $last, 31); # Put the block If ($size <= $spaceLast, sub {Jmp $end}); # We are finished because the last block had enough space $source += $toCopy; # Remaining source $size -= $toCopy; # Remaining source length my $new = $blockString->allocBlock; # Allocate new block $blockString->getBlock ($B, $new, 30); # Load the new block my ($next, $prev) = $blockString->getNextAndPrevBlockOffsetFromZmm(31); # Linkage from last block If ($first == $last, sub # The existing string has one block, add new as the second block {$blockString->putNextandPrevBlockOffsetIntoZmm(31, $new, $new); $blockString->putNextandPrevBlockOffsetIntoZmm(30, $last, $last); }, sub # The existing string has two or more blocks {$blockString->putNextandPrevBlockOffsetIntoZmm(31, $new, $prev); # From last block $blockString->putNextandPrevBlockOffsetIntoZmm(30, $next, $last); # From new block $blockString->putNextandPrevBlockOffsetIntoZmm(29, undef, $new); # From first block $blockString->putBlock($B, $first, 29); # Put the modified last block }); $blockString->putBlock($B, $last, 31); # Put the modified last block $blockString->putBlock($B, $new, 30); # Put the modified new block }; PopR @save; } in => {bs => 3, first => 3, source => 3, size => 3}; $s->call($blockString->address, $blockString->first, @variables); } sub Nasm::X86::BlockString::clear($) # Clear the block by freeing all but the first block {my ($blockString) = @_; # Block string descriptor @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters PushR my @save = (rax, r14, r15, zmm29, zmm30, zmm31); my $first = $$p{first}; # First block $blockString->getBlock($$p{bs}, $$p{first}, 29); # Get the first block my ($second, $last) = $blockString->getNextAndPrevBlockOffsetFromZmm(29); # Get the offsets of the second and last blocks ClearRegisters zmm29; # Clear first block $blockString->putNextandPrevBlockOffsetIntoZmm(29, $first, $first); # Initialize block chain $blockString->putBlock($$p{bs}, $first, 29); # Put the first block If ($last == $first, sub # String only has one block {}, sub # Two or more blocks on the chain {$$p{bs}->setReg(rax); # Address underlying byte string Lea r14, $blockString->bs->free->addr; # Address of address of free chain Mov r15, "[r14]"; # Address of free chain my $rfc = Vq('next', r15); # Remainder of the free chain If ($second == $last, sub # Two blocks on the chain {ClearRegisters zmm30; # Second block $blockString->putNextandPrevBlockOffsetIntoZmm(30, $rfc, undef); # Put second block on head of the list $blockString->putBlock($$p{bs}, $second, 30); # Put the second block }, sub # Three or more blocks on the chain {my $z = Vq(zero, 0); # A variable with zero in it $blockString->getBlock($$p{bs}, $second, 30); # Get the second block $blockString->getBlock($$p{bs}, $last, 31); # Get the last block $blockString->putNextandPrevBlockOffsetIntoZmm(30, undef, $z); # Reset prev pointer in second block $blockString->putNextandPrevBlockOffsetIntoZmm(31, $rfc, undef); # Reset next pointer in last block to remainder of free chain $blockString->putBlock($$p{bs}, $second, 30); # Put the second block $blockString->putBlock($$p{bs}, $last, 31); # Put the last block }), KeepFree r15; # Put the second block at the top of the free chain $second->setReg(r15); Mov "[r14]", r15; }); PopR @save; } in => {bs => 3, first => 3}; $s->call($blockString->address, $blockString->first); } #D1 Block Array # Array constructed as a tree of blocks in a byte string sub Nasm::X86::ByteString::CreateBlockArray($) # Create a block array in a byte string {my ($byteString) = @_; # Byte string description @_ == 1 or confess; my $b = RegisterSize zmm0; # Size of a block == size of a zmm register my $o = RegisterSize eax; # Size of a double word Comment "Allocate a new block array in a byte string"; my $p = 0; # Position in block my $s = genHash(__PACKAGE__."::BlockArray", # Block string definition bs => $byteString, # Bytes string definition width => $o, # Width of each element first => Vq('first'), # Variable addressing first block in block string slots1 => $b / $o - 1, # Number of slots in first block slots2 => $b / $o, # Number of slots in second and subsequent blocks ); $s->slots2 == 16 or confess "Number of slots per block not 16"; # Slots per block my $first = $s->allocBlock; # Allocate first block $s->first->copy($first); # Save first block $s # Description of block array } sub Nasm::X86::BlockArray::address($) # Address of a block string {my ($blockArray) = @_; # Block array descriptor @_ == 1 or confess; $blockArray->bs->bs; } sub Nasm::X86::BlockArray::allocBlock($) # Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable {my ($blockArray) = @_; # Block array descriptor @_ == 1 or confess; $blockArray->bs->allocBlock; } sub Nasm::X86::BlockArray::dump($@) # Dump a block array {my ($blockArray, @variables) = @_; # Block array descriptor, variables @_ >= 1 or confess; my $b = $blockArray->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $w = $blockArray->width; # The size of an entry in a block my $n = $blockArray->slots1; # The number of slots per block my $N = $blockArray->slots2; # The number of slots per block my $s = Subroutine {my ($p) = @_; # Parameters my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First block PushR my @save = (zmm30, zmm31); $b->getBlock($B, $F, 31); # Get the first block my $size = getDFromZmm(31, 0); # Size of array PrintOutStringNL("Block Array"); $size->out("Size: ", " "); PrintOutRegisterInHex zmm31; If ($size > $n, sub # Array has secondary blocks {my $T = $size / $N; # Number of full blocks $T->for(sub # Print out each block {my ($index, $start, $next, $end) = @_; # Execute body my $S = getDFromZmm(31, ($index + 1) * $w); # Address secondary block from first block $b->getBlock($B, $S, 30); # Get the secondary block $S->out("Full: ", " "); PrintOutRegisterInHex zmm30; }); my $lastBlockCount = $size % $N; # Number of elements in the last block If ($lastBlockCount, sub # Print non empty last block {my $S = getDFromZmm(31, ($T + 1) * $w); # Address secondary block from first block $b->getBlock($B, $S, 30); # Get the secondary block $S->out("Last: ", " "); PrintOutRegisterInHex zmm30; }); }); PopR @save; } in => {bs => 3, first => 3}; $s->call($blockArray->address, $blockArray->first, @variables); } sub Nasm::X86::BlockArray::push($@) # Push an element onto the array {my ($blockArray, @variables) = @_; # Block array descriptor, variables @_ >= 2 or confess; my $b = $blockArray->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $w = $blockArray->width; # The size of an entry in a block my $n = $blockArray->slots1; # The number of slots per block my $N = $blockArray->slots2; # The number of slots per block my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First block my $E = $$p{element}; # The element to be inserted PushR my @save = (zmm31); $b->getBlock($B, $F, 31); # Get the first block my $size = getDFromZmm(31, 0); # Size of array If ($size < $n, sub # Room in the first block {$E ->putDIntoZmm(31, ($size + 1) * $w); # Place element ($size+1)->putDIntoZmm(31, 0); # Update size $b ->putBlock($B, $F, 31); # Put the first block back into memory Jmp $success; # Element successfully inserted in first block }); If ($size == $n, sub # Migrate the first block to the second block and fill in the last slot {PushR my @save = (rax, k7, zmm30); Mov rax, -2; # Load compression mask Kmovq k7, rax; # Set compression mask Vpcompressd "zmm30{k7}{z}", zmm31; # Compress first block into second block ClearRegisters zmm31; # Clear first block ($size+1)->putDIntoZmm(31, 0); # Save new size in first block my $new = $b->allocBlock; # Allocate new block $new->putDIntoZmm(31, $w); # Save offset of second block in first block $E ->putDIntoZmm(30, $W - 1 * $w); # Place new element $b ->putBlock($B, $new, 30); # Put the second block back into memory $b ->putBlock($B, $F, 31); # Put the first block back into memory PopR @save; Jmp $success; # Element successfully inserted in second block }); If ($size <= $N * ($N - 1), sub # Still within two levels {If ($size % $N == 0, sub # New secondary block needed {PushR my @save = (rax, zmm30); my $new = $b->allocBlock; # Allocate new block $E ->putDIntoZmm(30, 0); # Place new element last in new second block ($size+1)->putDIntoZmm(31, 0); # Save new size in first block $new ->putDIntoZmm(31, ($size / $N + 1) * $w); # Address new second block from first block $b ->putBlock($B, $new, 30); # Put the second block back into memory $b ->putBlock($B, $F, 31); # Put the first block back into memory PopR @save; Jmp $success; # Element successfully inserted in second block }); if (1) # Continue with existing secondary block {PushR my @save = (rax, r14, zmm30); my $S = getDFromZmm(31, ($size / $N + 1) * $w); # Offset of second block in first block $b ->getBlock($B, $S, 30); # Get the second block $E ->putDIntoZmm(30, ($size % $N) * $w); # Place new element last in new second block ($size+1)->putDIntoZmm(31, 0); # Save new size in first block $b ->putBlock($B, $S, 30); # Put the second block back into memory $b ->putBlock($B, $F, 31); # Put the first block back into memory PopR @save; Jmp $success; # Element successfully inserted in second block } }); SetLabel $success; PopR @save; } in => {bs => 3, first => 3, element => 3}; $s->call($blockArray->address, $blockArray->first, @variables); } sub Nasm::X86::BlockArray::pop($@) # Pop an element from an array {my ($blockArray, @variables) = @_; # Block array descriptor, variables @_ >= 2 or confess; my $b = $blockArray->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $w = $blockArray->width; # The size of an entry in a block my $n = $blockArray->slots1; # The number of slots per block my $N = $blockArray->slots2; # The number of slots per block my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First block my $E = $$p{element}; # The element being popped PushR my @save = (zmm31); $b->getBlock($B, $F, 31); # Get the first block my $size = getDFromZmm(31, 0); # Size of array If ($size > 0, sub # Array has elements {If ($size <= $n, sub # In the first block {$E ->getDFromZmm(31, $size * $w); # Get element ($size-1)->putDIntoZmm(31, 0); # Update size $b ->putBlock($B, $F, 31); # Put the first block back into memory Jmp $success; # Element successfully retrieved from secondary block }); If ($size == $N, sub # Migrate the second block to the first block now that the last slot is empty {PushR my @save = (rax, k7, zmm30); my $S = getDFromZmm(31, $w); # Offset of second block in first block $b->getBlock($B, $S, 30); # Get the second block $E->getDFromZmm(30, $n * $w); # Get element from second block Mov rax, -2; # Load expansion mask Kmovq k7, rax; # Set expansion mask Vpexpandd "zmm31{k7}{z}", zmm30; # Expand second block into first block ($size-1)->putDIntoZmm(31, 0); # Save new size in first block $b -> putBlock($B, $F, 31); # Save the first block $b ->freeBlock($B, offset=>$S); # Free the now redundant second block PopR @save; Jmp $success; # Element successfully retrieved from secondary block }); If ($size <= $N * ($N - 1), sub # Still within two levels {If ($size % $N == 1, sub # Secondary block can be freed {PushR my @save = (rax, zmm30); my $S = getDFromZmm(31, ($size / $N + 1) * $w); # Address secondary block from first block $b ->getBlock($B, $S, 30); # Load secondary block $E->getDFromZmm(30, 0); # Get first element from secondary block Vq(zero, 0)->putDIntoZmm(31, ($size / $N + 1) * $w); # Zero at offset of secondary block in first block ($size-1)->putDIntoZmm(31, 0); # Save new size in first block $b ->freeBlock($B, offset=>$S); # Free the secondary block $b ->putBlock ($B, $F, 31); # Put the first block back into memory PopR @save; Jmp $success; # Element successfully retrieved from secondary block }); if (1) # Continue with existing secondary block {PushR my @save = (rax, r14, zmm30); my $S = getDFromZmm(31, (($size-1) / $N + 1) * $w); # Offset of secondary block in first block $b ->getBlock($B, $S, 30); # Get the secondary block $E ->getDFromZmm(30, (($size - 1) % $N) * $w); # Get element from secondary block ($size-1)->putDIntoZmm(31, 0); # Save new size in first block $b ->putBlock($B, $S, 30); # Put the secondary block back into memory $b ->putBlock($B, $F, 31); # Put the first block back into memory PopR @save; Jmp $success; # Element successfully retrieved from secondary block } }); }); SetLabel $success; PopR @save; } in => {bs => 3, first => 3}, out => {element => 3}; $s->call($blockArray->address, $blockArray->first, @variables); } sub Nasm::X86::BlockArray::get($@) # Get an element from the array {my ($blockArray, @variables) = @_; # Block array descriptor, variables @_ >= 3 or confess; my $b = $blockArray->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $w = $blockArray->width; # The size of an entry in a block my $n = $blockArray->slots1; # The number of slots in the first block my $N = $blockArray->slots2; # The number of slots in the secondary blocks my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First block my $E = $$p{element}; # The element to be returned my $I = $$p{index}; # Index of the element to be returned PushR my @save = (zmm31); $b->getBlock($B, $F, 31); # Get the first block my $size = getDFromZmm(31, 0); # Size of array If ($I < $size, sub # Index is in array {If ($size <= $n, sub # Element is in the first block {$E->getDFromZmm(31, ($I + 1) * $w); # Get element Jmp $success; # Element successfully inserted in first block }); If ($size <= $N * ($N - 1), sub # Still within two levels {my $S = getDFromZmm(31, ($I / $N + 1) * $w); # Offset of second block in first block $b->getBlock($B, $S, 31); # Get the second block $E->getDFromZmm(31, ($I % $N) * $w); # Offset of element in second block Jmp $success; # Element successfully inserted in second block }); }); PrintErrString "Index out of bounds on get from array, "; # Array index out of bounds $I->err("Index: "); PrintErrString " "; $size->errNL("Size: "); Exit(1); SetLabel $success; PopR @save; } in => {bs => 3, first => 3, index => 3}, out => {element => 3}; $s->call($blockArray->address, $blockArray->first, @variables); } sub Nasm::X86::BlockArray::put($@) # Put an element into an array as long as it is with in its limits established by pushing. {my ($blockArray, @variables) = @_; # Block array descriptor, variables @_ >= 3 or confess; my $b = $blockArray->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $w = $blockArray->width; # The size of an entry in a block my $n = $blockArray->slots1; # The number of slots in the first block my $N = $blockArray->slots2; # The number of slots in the secondary blocks my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First block my $E = $$p{element}; # The element to be added my $I = $$p{index}; # Index of the element to be inserted PushR my @save = (zmm31); $b->getBlock($B, $F, 31); # Get the first block my $size = getDFromZmm(31, 0 ); # Size of array If ($I < $size, sub # Index is in array {If ($size <= $n, sub # Element is in the first block {$E->putDIntoZmm(31, ($I + 1) * $w); # Put element $b->putBlock($B, $F, 31); # Get the first block Jmp $success; # Element successfully inserted in first block }); If ($size <= $N * ($N - 1), sub # Still within two levels {my $S = getDFromZmm(31, ($I / $N + 1) * $w); # Offset of second block in first block $b->getBlock($B, $S, 31); # Get the second block $E->putDIntoZmm(31, ($I % $N) * $w); # Put the element into the second block in first block $b->putBlock($B, $S, 31); # Get the first block Jmp $success; # Element successfully inserted in second block }); }); PrintErrString "Index out of bounds on put to array, "; # Array index out of bounds $I->err("Index: "); PrintErrString " "; $size->errNL("Size: "); Exit(1); SetLabel $success; PopR @save; } in => {bs => 3, first => 3, index => 3, element => 3}; $s->call($blockArray->address, $blockArray->first, @variables); } #D1 Block Multi Way Tree # Multi Way Tree constructed as a tree of blocks in a byte string sub Nasm::X86::ByteString::CreateBlockMultiWayTree($) # Create a block multi way tree in a byte string {my ($byteString) = @_; # Byte string description @_ == 1 or confess; my $b = RegisterSize zmm0; # Size of a block == size of a zmm register my $o = RegisterSize eax; # Size of a double word Comment "Allocate a new block multi way tree in a byte string"; my $s = genHash(__PACKAGE__."::BlockMultiWayTree", # Block multi way tree bs => $byteString, # Byte string definition first => undef, # Variable addressing offset to first block of keys width => $o, # Width of a key or data slot keys => $o * 1, # Offset of keys in header data => $o * 2, # Offset of data in header node => $o * 3, # Offset of nodes in header minKeys => int($b / 2) - 1, # Minimum number of keys maxKeys => $b / $o - 2, # Maximum number of keys maxNodes => $b / $o - 1, # Maximum number of children per parent. loop => $b - $o, # Offset of keys, data, node loop length => $b - $o * 2, # Offset of length in keys block up => $b - $o * 2, # Offset of up in data block head => undef, # Offset of header block ); confess "Maximum keys must be 14" unless $s->maxKeys == 14; # Maximum number of keys is expected to be 14 my $keys = $s->first = $s->allocBlock; # Allocate first keys block my $data = $s->allocBlock; # Allocate first data block ClearRegisters zmm31; # Initialize first keys, data, node loop $s->putLoop($data, 31); # Keys loops to data $byteString->putBlock($s->address, $keys, 31); # Write first keys $s # Description of block array } sub Nasm::X86::BlockMultiWayTree::allocKeysDataNode($$$$@) #P Allocate a keys/data/node block and place it in the numbered zmm registers {my ($bmt, $K, $D, $N, @variables) = @_; # Block multi way tree descriptor, numbered zmm for keys, numbered zmm for data, numbered zmm for children, variables @_ >= 4 or confess; my $s = Subroutine {my ($parameters) = @_; # Parameters my $B = $$parameters{bs}; # Byte string $bmt->bs->allocZmmBlock($B, my $k = Vq(offset)); # Keys $bmt->bs->allocZmmBlock($B, my $d = Vq(offset)); # Data $bmt->bs->allocZmmBlock($B, my $n = Vq(offset)); # Children $bmt->putLoop($d, $K); # Set the link from key to data $bmt->putLoop($n, $D); # Set the link from data to node $bmt->putLoop($k, $N); # Set the link from node to key } name=>qq(Nasm::X86::BlockMultiWayTree::allocKeysDataNode::${K}::${D}::${N}), # Create a subroutine for each combination of registers encountered in => {bs => 3}; $s->call($bmt->address, @variables); } # allocKeysDataNode sub Nasm::X86::BlockMultiWayTree::splitNode($$$$@) #P Split a node given its offset in a byte string retaining the key being inserted in the node split while putting the remainder to the left or right. {my ($bmt, $bs, $node, $key, @variables) = @_; # Block multi way tree descriptor, backing byte string, offset of node, key, variables @_ >= 4 or confess; my $K = 31; my $D = 30; my $N = 29; # Key, data, node blocks my $s = Subroutine {my ($parameters) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $b = $$parameters{bs}; # Byte string my $k = $$parameters{key}; # Key we are looking for my $n = $$parameters{node}; # Node to split PushR my @save = (zmm 22..31); $bmt->getKeysDataNode($n, $K, $D, $N); # Load root node If ($bmt->getLengthInKeys($K) != $bmt->maxKeys, sub # Only split full blocks {Jmp $success; }); my $p = $bmt->getUpFromData($D); # Parent If ($p, sub # Not the root {my $s = getDFromZmm($K, ($bmt->minKeys + 1) * $bmt->width); # Splitting key If ($k < $s, sub # Split left node pushing remainder right so that we keep the key we are looking for in the left node {Vmovdqu64 zmm28, zmm31; # Load left node Vmovdqu64 zmm27, zmm30; Vmovdqu64 zmm26, zmm29; $bmt->allocKeysDataNode(25, 24, 23); # Create new right node KeepFree zmm $N; # Reloading root $bmt->getKeysDataNode($p, $K, $D, $N); # Load parent $bmt->splitFullLeftNode($b); $bmt->putKeysDataNode($p, $K, $D, $N); # Save parent $bmt->putKeysDataNode($n, 28, 27, 26); # Save left my $r = $bmt->getLoop (23); # Offset of right keys $bmt->putUpIntoData ($p, 24); # Reparent new block $bmt->putKeysDataNode($r, 25, 24, 23); # Save right back into node we just split }, sub # Split right node pushing remainder left so that we keep the key we are looking for in the right node {Vmovdqu64 zmm25, zmm31; # Load right node Vmovdqu64 zmm24, zmm30; Vmovdqu64 zmm23, zmm29; $bmt->allocKeysDataNode(28, 27, 26); # Create new left node KeepFree zmm $N; # Reloading root $bmt->getKeysDataNode($p, $K, $D, $N); # Load parent $bmt->splitFullRightNode($b); $bmt->putKeysDataNode($p, $K, $D, $N); # Save parent my $l = $bmt->getLoop (26); # Offset of left keys $bmt->putUpIntoData ($p, 27); # Reparent new block $bmt->putKeysDataNode($l, 28, 27, 26); # Save left $bmt->putKeysDataNode($n, 25, 24, 23); # Save right back into node we just split }); }, sub {$bmt->splitFullRoot($b); # Root my $l = getDFromZmm($N, 0); my $r = getDFromZmm($N, $bmt->width); $bmt->putKeysDataNode($n, $K, $D, $N); # Save root $bmt->putKeysDataNode($l, 28, 27, 26); # Save left $bmt->putKeysDataNode($r, 25, 24, 23); # Save right }); SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3, node => 3, key => 3}; $s->call(bs=>$bs, node=>$node, key=>$key, @variables); } # splitNode sub Nasm::X86::BlockMultiWayTree::reParent($$$$$@) #P Reparent the children of a node held in registers. The children are in the backing byte string not registers. {my ($bmt, $bs, $PK, $PD, $PN, @variables) = @_; # Block multi way tree descriptor, backing byte string, numbered zmm key node, numbered zmm data node, numbered zmm child node, variables @_ >= 5 or confess; my $b = $bmt->bs; # Underlying byte string my $s = Subroutine {my ($parameters) = @_; # Parameters my $B = $$parameters{bs}; # Byte string my $L = $bmt->getLengthInKeys($PK) + 1; # Number of children my $p = $bmt->getUpFromData ($PD); # Parent node offset as a variable If ($bmt->getLoop($PD), sub # Not a leaf {PushR my @save = (rax, rdi); Mov rdi, rsp; # Save stack base PushRR "zmm$PN"; # Child nodes on stack my $w = $bmt->width; my $l = $bmt->loop; my $u = $bmt->up; # Steps we will make along the chain my $s = Vq(start); $L->for(sub # Each child {my ($index, $start, $next, $end) = @_; &PopEax; # The nodes are double words but we cannot pop a double word from the stack in 64 bit long mode using pop $s->getReg(rax); KeepFree rax; $b->putChain($B, $s, $p, $l, $u); }); Mov rsp, rdi; # Level stack PopR @save; }); } in => {bs => 3}; $s->call($bmt->address, @variables); } # reParent sub Nasm::X86::BlockMultiWayTree::splitFullRoot($$) #P Split a full root block held in 31..29 and place the left block in 28..26 and the right block in 25..23. The left and right blocks should have their loop offsets set so they can be inserted into the root. {my ($bmt, $bs) = @_; # Block multi way tree descriptor, byte string locator @_ == 2 or confess; my $length = $bmt->maxKeys; # Length of block to split my $leftLength = $length / 2; # Left split point my $rightLength = $length - 1 - $leftLength; # Right split point my $TK = 31; my $TD = 30; my $TN = 29; # Root key, data, node my $LK = 28; my $LD = 27; my $LN = 26; # Key, data, node blocks in left child my $RK = 25; my $RD = 24; my $RN = 23; # Key, data, node blocks in right child my $Test = 22; # Zmm used to hold test values via broadcast my $s = Subroutine {my ($parameters) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$parameters{bs}; PushR my @save = (k6, k7, zmm22); If ($bmt->getLengthInKeys($TK) != $bmt->maxKeys, sub # Only split full blocks {Jmp $success; }); $bmt->allocKeysDataNode( 28, 27, 26); # Allocate immediate children of the root my $l = $bmt->getLoop( 26); $bmt->putKeysDataNode($l, 28, 27, 26); $bmt->allocKeysDataNode (25, 24, 23); my $r = $bmt->getLoop (23); $bmt->putKeysDataNode($l, 25, 24, 23); $bmt->reParent ($B, 28, 27, 26); # Reparent grandchildren $bmt->reParent ($B, 25, 24, 23); my $n = $bmt->getLoop($TD); # Offset of node block or zero if there is no node block my $to = $bmt->getLoop($TN); # Offset of root block my $lo = $bmt->getLoop($LN); # Offset of left block my $ro = $bmt->getLoop($RN); # Offset of right block LoadConstantIntoMaskRegister(k7, eval "0b11".'0'x$length); # Area to clear preserving loop and up/length &Vmovdqu32 (zmm $LK."{k7}{z}", $LK); # Clear left &Vmovdqu32 (zmm $LD."{k7}{z}", $LD); &Vmovdqu32 (zmm $RK."{k7}{z}", $RK); # Clear right &Vmovdqu32 (zmm $RD."{k7}{z}", $RD); LoadConstantIntoMaskRegister(k7, eval "0b10".'0'x$length); # Area to clear preserving loop &Vmovdqu32 (zmm $LN."{k7}{z}", $LN); # Clear left &Vmovdqu32 (zmm $RK."{k7}{z}", $RK); # Clear right LoadConstantIntoMaskRegister(k7, eval "0b".'1'x$leftLength); # Constant mask up to the split point &Vmovdqu32 (zmm $LK."{k7}", $TK); # Split keys left &Vmovdqu32 (zmm $LD."{k7}", $TD); # Split data left If ($n, sub # Split nodes left {&Vmovdqu32 (zmm $LN."{k7}", $TN); }); my $mr = eval "0b".('1'x$rightLength).('0'x($leftLength+1)); # Right mask LoadConstantIntoMaskRegister(k6, $mr); # Constant mask from one beyond split point to end of keys LoadConstantIntoMaskRegister(k7, eval "0b".'1'x$rightLength); # Constant mask for compressed right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $TK); # Split right keys &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right keys &Vmovdqu32 (zmm $RK. "{k7}", $Test); # Save right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $TD); # Split right data &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right data &Vmovdqu32 (zmm $RD. "{k7}", $Test); # Save right data If ($n, sub # Split nodes right {&Vmovdqu32 (zmm $Test."{k6}{z}", $TN); # Split right nodes &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right node &Vmovdqu32 (zmm $RN. "{k7}", $Test); # Save right node }); my $k = getDFromZmm $TK, $leftLength * (my $w = $bmt->width); # Splitting key my $d = getDFromZmm $TD, $leftLength * $w; # Splitting data LoadConstantIntoMaskRegister(k7, 1); # Position of key, data in root node $k->zBroadCastD($Test); # Broadcast keys &Vmovdqu32 (zmm $TK."{k7}", $Test); # Insert key in root $d->zBroadCastD($Test); # Broadcast keys &Vmovdqu32 (zmm $TD."{k7}", $Test); # Insert data in root LoadConstantIntoMaskRegister(k7, eval "0b11".('0'x($length-1)).'1'); # Unused fields &Vmovdqu32 (zmm $TK."{k7}{z}", $TK); # Clear unused keys in root &Vmovdqu32 (zmm $TD."{k7}{z}", $TD); # Clear unused data in root If ($n, sub {LoadConstantIntoMaskRegister(k7, eval "0b1".('0'x($length)).'1'); # Unused fields &Vmovdqu32 (zmm $TN."{k7}{z}", $TN); # Clear unused node in root }); $bmt->putLengthInKeys($TK, Cq(one, 1)); # Set length of root keys $bmt->putLengthInKeys($LK, Cq(leftLength, $leftLength)); # Length of left node $bmt->putLengthInKeys($RK, Cq(rightLength, $rightLength)); # Length of right node $bmt->putUpIntoData($to, $LD); # Set parent of left node $bmt->putUpIntoData($to, $RD); # Set parent of right node $lo->putDIntoZmm($TN, 0); # Insert offset of left node in root nodes $ro->putDIntoZmm($TN, $w); # Insert offset of right node in root nodes SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3}; $s->call (bs => $bs); } # splitFullRoot sub Nasm::X86::BlockMultiWayTree::splitFullLeftNode($$) #P Split a full left node block held in 28..26 whose parent is in 31..29 and place the new right block in 25..23. The parent is assumed to be not full. The loop and length fields are assumed to be authoritative and hence are preserved. {my ($bmt, $bs) = @_; # Block multi way tree descriptor, byte string locator @_ == 2 or confess; my $length = $bmt->maxKeys; # Length of block to split my $leftLength = $length / 2; # Left split point my $rightLength = $length - 1 - $leftLength; # Right split point my $PK = 31; my $PD = 30; my $PN = 29; # Root key, data, node my $LK = 28; my $LD = 27; my $LN = 26; # Key, data, node blocks in left child my $RK = 25; my $RD = 24; my $RN = 23; # Key, data, node blocks in right child my $Test = 22; # Zmm used to hold test values via broadcast my $s = Subroutine {my ($parameters) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$parameters{bs}; PushR my @save = (k6, k7, zmm22); If ($bmt->getLengthInKeys($LK) != $bmt->maxKeys, sub # Only split full blocks {Jmp $success; }); my $n = $bmt->getLoop($LD); # Offset of node block or zero if there is no node block for the left node my $lo = $bmt->getLoop($LN); # Offset of left block my $ro = $bmt->getLoop($RN); # Offset of right block ClearRegisters k6, k7, zmm22; my $k = getDFromZmm $LK, $leftLength * (my $w = $bmt->width); # Splitting key my $d = getDFromZmm $LD, $leftLength * $w; # Splitting data my $mr = eval "0b".('1'x$rightLength).('0'x($leftLength+1)); # Right mask LoadConstantIntoMaskRegister(k6, $mr); # Constant mask from one beyond split point to end of keys LoadConstantIntoMaskRegister(k7, eval "0b".'1'x$rightLength); # Constant mask for compressed right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $LK); # Split out right keys &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right keys &Vmovdqu32 (zmm $RK. "{k7}", $Test); # Save right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $LD); # Split out right data &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right data &Vmovdqu32 (zmm $RD. "{k7}", $Test); # Save right data If ($n, sub # Split nodes right {&Vmovdqu32 (zmm $Test."{k6}{z}", $LN); # Split right nodes &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right node &Vmovdqu32 (zmm $RN. "{k7}", $Test); # Save right node }); if (1) # Prepare mask to reset moved keys {my $B = "0b11".('0'x($rightLength+1)).('1'x($leftLength)); # Areas to retain my $b = eval $B; LoadConstantIntoMaskRegister(k7, $b); } &Vmovdqu32 (zmm $LK."{k7}{z}", $LK); # Remove unused keys &Vmovdqu32 (zmm $LD."{k7}{z}", $LD); # Split data left If ($n, sub # Split nodes left {my $B = "0b10".('0'x($rightLength+1)).('1'x($leftLength)); # Areas to retain my $b = eval $B; LoadConstantIntoMaskRegister(k7, $b); # Areas to retain &Vmovdqu32 (zmm $LN."{k7}{z}", $LN); }); $lo->zBroadCastD($Test); # Find index in parent of left node - broadcast offset of left node so we can locate it in the parent LoadConstantIntoMaskRegister(k7, eval "0b".('1'x$length)); # Nodes &Vpcmpud("k6{k7}", zmm($PN, $Test), 0); # Check for equal offset - one of them will match to create the single insertion point in k6 Kandnq k5, k6, k7; # Expansion mask &Vpexpandd (zmm $PK."{k5}", $PK); # Shift up keys &Vpexpandd (zmm $PD."{k5}", $PD); # Shift up keys $k->zBroadCastD($Test); # Broadcast new key &Vmovdqu32 (zmm $PK."{k6}", $Test); # Insert new key $d->zBroadCastD($Test); # Broadcast new data &Vmovdqu32 (zmm $PD."{k6}", $Test); # Insert new data If ($n, sub # Insert new right node offset into parent nodes {Kshiftlq k6, k6, 1; # Node insertion point Kandnq k5, k6, k7; # Expansion mask &Vpexpandd (zmm $PN."{k5}", $PN); # Shift up nodes $ro->zBroadCastD($Test); # Broadcast right node offset &Vmovdqu32 (zmm $PN."{k6}", $Test); # Insert right node offset }); my $l = $bmt->getLengthInKeys($PK); # Length of parent $bmt->putLengthInKeys($PK, $l + 1); # New length of parent $bmt->putLengthInKeys($LK, Cq(leftLength, $leftLength)); # Length of left node $bmt->putLengthInKeys($RK, Cq(rightLength, $rightLength)); # Length of right node SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3}; $s->call (bs => $bs); } # splitFullLeftNode sub Nasm::X86::BlockMultiWayTree::splitFullRightNode($$) #P Split a full right node block held in 25..23 whose parent is in 31..29 and place the new left block in 25..23. The loop and length fields are assumed to be authoritative and hence are preserved. {my ($bmt, $bs) = @_; # Block multi way tree descriptor, byte string locator @_ == 2 or confess; my $length = $bmt->maxKeys; # Length of block to split my $leftLength = $length / 2; # Left split point my $rightLength = $length - 1 - $leftLength; # Right split point my $PK = 31; my $PD = 30; my $PN = 29; # Root key, data, node my $LK = 28; my $LD = 27; my $LN = 26; # Key, data, node blocks in left child my $RK = 25; my $RD = 24; my $RN = 23; # Key, data, node blocks in right child my $Test = 22; # Zmm used to hold test values via broadcast my $s = Subroutine {my ($parameters) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$parameters{bs}; PushR my @save = (k6, k7, zmm22); If ($bmt->getLengthInKeys($RK) != $bmt->maxKeys, sub # Only split full blocks {Jmp $success; }); my $n = $bmt->getLoop($RD); # Offset of node block or zero if there is no node block for the right node my $lo = $bmt->getLoop($LN); # Offset of left block my $ro = $bmt->getLoop($RN); # Offset of right block ClearRegisters k6, k7; # Clear mask registers LoadConstantIntoMaskRegister k7, eval "0b00".(1)x$length; # Left mask for keys and data &Vmovdqu32(zmm $LK."{k7}", $RK); # Copy right keys to left node &Vmovdqu32(zmm $LD."{k7}", $RD); # Copy right data to left node LoadConstantIntoMaskRegister k7, eval "0b01".(1)x$length; # Left mask for child nodes &Vmovdqu32(zmm $LN."{k7}", $RN); # Copy right nodes to left node my $k = getDFromZmm $LK, $leftLength * (my $w = $bmt->width); # Splitting key my $d = getDFromZmm $LD, $leftLength * $w; # Splitting data my $mr = eval "0b".('1'x$rightLength).('0'x($leftLength+1)); # Right mask LoadConstantIntoMaskRegister(k6, $mr); # Constant mask from one beyond split point to end of keys LoadConstantIntoMaskRegister(k7, eval "0b".'1'x$rightLength); # Constant mask for compressed right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $LK); # Split out right keys &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right keys &Vmovdqu32 (zmm $RK. "{k7}", $Test); # Save right keys &Vmovdqu32 (zmm $Test."{k6}{z}", $LD); # Split out right data &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right data &Vmovdqu32 (zmm $RD. "{k7}", $Test); # Save right data If ($n, sub # Split nodes right {&Vmovdqu32 (zmm $Test."{k6}{z}", $LN); # Split right nodes &Vpcompressd (zmm $Test."{k6}", $Test); # Compress right node &Vmovdqu32 (zmm $RN. "{k7}", $Test); # Save right node }); my $Br = "0b11".('0'x($rightLength+2)).('1'x($leftLength-1)); # Areas to retain on right my $br = eval $Br; LoadConstantIntoMaskRegister(k7, $br); # Areas to retain my $Lr = "0b11".('0'x($rightLength+1)).('1'x($leftLength)); # Areas to retain on left my $lr = eval $Lr; LoadConstantIntoMaskRegister(k6, $lr); # Areas to retain &Vmovdqu32 (zmm $RK."{k7}{z}", $RK); # Remove unused keys on right &Vmovdqu32 (zmm $RD."{k7}{z}", $RD); # Remove unused data on right If ($n, sub # Split nodes left {my $Br = "0b10".('0'x($rightLength+2)).('1'x($leftLength-1)); # Areas to retain my $br = eval $Br; LoadConstantIntoMaskRegister(k7, $br); &Vmovdqu32 (zmm $RN."{k7}{z}", $RN); }); &Vmovdqu32 (zmm $LK."{k6}{z}", $LK); # Remove unused keys on left &Vmovdqu32 (zmm $LD."{k6}{z}", $LD); # Remove unused data on left If ($n, sub # Split nodes left {my $Lr = "0b10".('0'x($rightLength+1)).('1'x($leftLength)); # Areas to retain my $lr = eval $Lr; LoadConstantIntoMaskRegister(k6, $lr); &Vmovdqu32 (zmm $LN."{k6}{z}", $LN); }); $ro->zBroadCastD($Test); # Find index in parent of right node - broadcast offset of right node so we can locate it in the parent LoadConstantIntoMaskRegister(k7, eval "0b".('1'x$length)); # Nodes &Vpcmpud("k6{k7}", zmm($PN, $Test), 0); # Check for equal offset - one of them will match to create the single insertion point in k6 Kandnq k5, k6, k7; # Expansion mask &Vpexpandd (zmm $PK."{k5}", $PK); # Shift up keys &Vpexpandd (zmm $PD."{k5}", $PD); # Shift up keys $k->zBroadCastD($Test); # Broadcast new key &Vmovdqu32 (zmm $PK."{k6}", $Test); # Insert new key $d->zBroadCastD($Test); # Broadcast new data &Vmovdqu32 (zmm $PD."{k6}", $Test); # Insert new data If ($n, sub # Insert new left node offset into parent nodes {Kandnq k5, k6, k7; # Expansion mask &Vpexpandd (zmm $PN."{k5}", $PN); # Shift up nodes $lo->zBroadCastD($Test); # Broadcast left node offset &Vmovdqu32 (zmm $PN."{k6}", $Test); # Insert right node offset }); my $l = $bmt->getLengthInKeys($PK); # Length of parent $bmt->putLengthInKeys($PK, $l + 1); # New length of parent $bmt->putLengthInKeys($LK, Cq(leftLength, $leftLength)); # Length of left node $bmt->putLengthInKeys($RK, Cq(rightLength, $rightLength)); # Length of right node SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3}; $s->call (bs => $bs); } # splitFullRightNode sub Nasm::X86::BlockMultiWayTree::findAndSplit($@) #P Find a key in a tree which is known to contain at least one key splitting full nodes along the path to the key. {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables @_ >= 3 or confess; my $W = $bmt->width; # Width of keys and data my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First keys block my $K = $$p{key}; # Key to find my $tree = $F->clone; # Start at the first key block PushR my @save = (k6, k7, r14, r15, zmm28, zmm29, zmm30, zmm31); my $zmmKeys = 31; my $zmmData = 30; my $zmmNode = 29; my $zmmTest = 28; my $lengthMask = k6; my $testMask = k7; $K->setReg(r15); # Load key into test register Vpbroadcastd "zmm$zmmTest", r15d; KeepFree r15; $bmt->splitNode($B, $F, $K); # Split the root ForEver # Step down through tree {my ($start, $end) = @_; # Parameters $bmt->getKeysDataNode($tree, $zmmKeys, $zmmData, $zmmNode); # Get the keys/data/nodes block my $node = getDFromZmm($zmmNode, 0); # First element of node block, which will be zero if we are on a leaf my $l = $bmt->getLengthInKeys($zmmKeys); # Length of the block $l->setMaskFirst($lengthMask); # Set the length mask Vpcmpud "$testMask\{$lengthMask}", "zmm$zmmKeys", "zmm$zmmTest", 0; # Check for equal elements Ktestw $testMask, $testMask; IfNz # Result mask is non zero so we must have found the key {Kmovq r15, $testMask; Tzcnt r14, r15; # Trailing zeros gives index $$p{compare}->copy(Cq(zero, 0)); # Key found $$p{index} ->getReg(r14); # Index from trailing zeros $$p{offset} ->copy($tree); # Offset of matching block Jmp $success; # Return }; Vpcmpud "$testMask\{$lengthMask}", "zmm$zmmTest", "zmm$zmmKeys", 1; # Check for greater elements Ktestw $testMask, $testMask; IfNz # Non zero implies that the key is less than some of the keys in the block {Kmovq r15, $testMask; Tzcnt r14, r15; # Trailing zeros If ($node == 0, sub # We are on a leaf {$$p{compare}->copy(Cq(minusOne, -1)); # Key less than $$p{index} ->getReg(r14); # Index from trailing zeros $$p{offset} ->copy($tree); # Offset of matching block Jmp $success; # Return }); $tree->copy(getDFromZmm($zmmNode, "r14*$W")); # Corresponding node Jmp $start; # Loop }; if (1) # Key greater than all keys in block {If ($node == 0, sub # We have reached a leaf {$$p{compare}->copy(Cq(plusOne, +1)); # Key greater than last key $$p{index} ->copy($l-1); # Index of last key which we are greater than $$p{offset} ->copy($tree); # Offset of matching block Jmp $success }); }; $tree->copy(getDFromZmm($zmmNode, $l * $bmt->width)); # Greater than all keys so step through last child node }; SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3, first => 3, key => 3}, out => {compare => 3, offset => 3, index => 3}; $s->call($bmt->address, first => $bmt->first, @variables); } # findAndSplit sub Nasm::X86::BlockMultiWayTree::find($@) # Find a key in a tree and return its associated data {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables @_ >= 3 or confess; my $W = $bmt->width; # Width of keys and data my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First keys block my $K = $$p{key}; # Key to find my $tree = $F->clone; # Start at the first key block PushR my @save = (k6, k7, r14, r15, zmm28, zmm29, zmm30, zmm31); my $zmmKeys = 31; my $zmmData = 30; my $zmmNode = 29; my $zmmTest = 28; my $lengthMask = k6; my $testMask = k7; $K->setReg(r15); # Load key into test register Vpbroadcastd "zmm$zmmTest", r15d; KeepFree r15; Cq(loop, 99)->for(sub # Step down through tree {my ($index, $start, $next, $end) = @_; $bmt->getKeysDataNode($tree, $zmmKeys, $zmmData, $zmmNode); # Get the keys block my $l = $bmt->getLengthInKeys($zmmKeys); # Length of the block If ($l == 0, sub # Empty tree so we have not found the key {$$p{found}->copy(Cq(zero, 0)); # Key not found Jmp $success; # Return }); $l->setMaskFirst($lengthMask); # Set the length mask Vpcmpud "$testMask\{$lengthMask}", "zmm$zmmKeys", "zmm$zmmTest", 0; # Check for equal elements Ktestw $testMask, $testMask; IfNz # Result mask is non zero so we must have found the key {Kmovq r15, $testMask; Tzcnt r14, r15; # Trailing zeros $$p{found}->copy(Cq(one, 1)); # Key found $$p{data}->copy(getDFromZmm($zmmData, "r14*$W")); # Data associated with the key Jmp $success; # Return }; my $n = getDFromZmm($zmmNode, 0); # First child empty implies we are on a leaf If ($n == 0, sub # Zero implies that this is a leaf node {$$p{found}->copy(Cq(zero, 0)); # Key not found Jmp $success; # Return }); Vpcmpud "$testMask\{$lengthMask}", "zmm$zmmTest", "zmm$zmmKeys", 1; # Check for greater elements Ktestw $testMask, $testMask; IfNz # Non zero implies that the key is less than some of the keys {Kmovq r15, $testMask; Tzcnt r14, r15; # Trailing zeros $tree->copy(getDFromZmm($zmmNode, "r14*$W")); # Corresponding node Jmp $next; # Loop }; $tree->copy(getDFromZmm($zmmNode, $l * $W)); # Greater than all keys }); PrintErrStringNL "Stuck in find"; # We seem to be looping endlessly Exit(1); SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3, first => 3, key => 3}, out => {data => 3, found => 3}; $s->call($bmt->address, first => $bmt->first, @variables); } # find sub Nasm::X86::BlockMultiWayTree::insert($@) # Insert a (key, data) pair into the tree {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables @_ >= 2 or confess; my $b = $bmt->bs; # Underlying byte string my $W = RegisterSize zmm0; # The size of a block my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$p{bs}; # Byte string my $F = $$p{first}; # First keys block my $K = $$p{key}; # Key to be inserted my $D = $$p{data}; # Data to be inserted PushR my @save = (k4, k5, k6, k7, r14, r15, zmm 22..31); $bmt->getKeysDataNode($F, 31, 30, 29); # Get the first block my $l = $bmt->getLengthInKeys(31); # Length of the block If $l == 0, Then # Empty tree {$K->putDIntoZmm (31, 0); # Write key $bmt->putLengthInKeys (31, Cq(one, 1)); # Set the length of the block $D->putDIntoZmm (30, 0); # Write data $bmt->putKeysData($F, 31, 30); # Write the data block back into the underlying byte string Jmp $success; # Insert completed successfully }; my $n = $bmt->getLoop(30); # Get the offset of the node block If (($n == 0) & ($l < $bmt->maxKeys), Then # Node is root with no children and space for more keys {$l->setMaskFirst(k7); # Set the compare bits $K->setReg(r15); # Key to search for Vpbroadcastd zmm22, r15d; # Load key KeepFree r15; Vpcmpud "k6{k7}", zmm22, zmm31, 0; # Check for equal key ClearRegisters k5; # Zero so we can check the result mask against zero Ktestd k5, k6; # Check whether a key was equal IfNz # We found a key {$bmt->putLengthInKeys(31, $l + 1); # Set the length of the block $D->setReg(r14); # Key to search for Vpbroadcastd "zmm30{k6}", r14d; # Load data $bmt->putKeysData($F, 31, 30); # Write the data block back into the underlying byte string KeepFree r14; Jmp $success; # Insert completed successfully }; Vpcmpud "k6{k7}", zmm22, zmm31, 1; # Check for elements that are greater Ktestw k6, k6; IfEq (sub # K6 zero implies the latest key goes at the end {Kshiftlw k6, k7, 1; # Reach next empty field Kandnw k6, k7, k6; # Remove back fill to leave a single bit at the next empty field }, sub {Kandw k5, k6, k7; # Tested at: # Insert key for BlockMultiWayTree but we could simplify by using a mask for the valid area Kandnw k4, k5, k7; Kshiftlw k5, k5, 1; Korw k5, k4, k5; # Broadcast mask Kandnw k6, k5, k7; # Expand mask Vpexpandd "zmm31{k5}", zmm31; # Shift up keys Vpexpandd "zmm30{k5}", zmm30; # Shift up data }); Vpbroadcastd "zmm31{k6}", r15d; # Load key $D->setReg(r14); # Corresponding data Vpbroadcastd "zmm30{k6}", r14d; # Load data KeepFree r14; $bmt->putLengthInKeys( 31, $l + 1); # Set the length of the block If $l + 1 == $bmt->maxKeys, Then # Root is now full so we have to allocate node block for it and chain it in {$bmt->bs->allocZmmBlock($B, my $n = Vq(offset)); # Children $bmt->putLoop($n, 30); # Set the link from data to node $bmt->putLoop($F, 29); # Set the link from node to key }; $bmt->putKeysDataNode($F, 31, 30, 29); # Write the data block back into the underlying byte string $bmt->splitNode($B, $F, $K); # Split if the leaf has got too big Jmp $success; # Insert completed successfully }); my $compare = Vq(compare); # Comparison result my $offset = Vq(offset); # Offset of result my $index = Vq('index'); # Index of result $bmt->findAndSplit($K, $compare, $offset, $index); # Split node if full KeepFree zmm 29; $bmt->getKeysDataNode($offset, 31, 30, 29); If $compare == 0, Then # Found an equal key so update the data {$D->putDIntoZmm(30, $index * $bmt->width); # Update data at key $bmt->putKeysDataNode($offset, 31, 30, 29); # Rewrite data and keys }, Else # We have room for the insert because each block has been split to make it non full {If $compare > 0, Then # Position at which to insert new key if it is greater than the indexed key {++$index; }; my $length = $bmt->getLengthInKeys(31); # Number of keys If $index < $length, Then # Need to expand as we cannot push {$length->setMaskFirst(k7); # Length as bits Kshiftlw k6, k7, 1; # Length plus one as bits with a trailing zero Korw k6, k6, k7; # Length plus one as bits with no trailing zero $index->clearMaskBit(k6); # Zero at the index Vpexpandd "zmm31{k6}", zmm31; # Shift up keys Vpexpandd "zmm30{k6}", zmm30; # Shift up data }; ClearRegisters k7; $index->setMaskBit(k7); # Set bit at insertion point $K->setReg(r15); # Corresponding data Vpbroadcastd "zmm31{k7}", r15d; # Load key $D->setReg(r14); # Corresponding data Vpbroadcastd "zmm30{k7}", r14d; # Load data $bmt->putLengthInKeys(31, $length + 1); # Set the new length of the block $bmt->putKeysDataNode($offset, 31, 30, 29); # Rewrite data and keys $bmt->splitNode($B, $offset, $K); # Split if the leaf has got too big }; SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3, first => 3, key => 3, data => 3}; $s->call($bmt->address, first => $bmt->first, @variables); } # insert sub Nasm::X86::BlockMultiWayTree::getKeysData($$$$) # Load the keys and data blocks for a node {my ($bmt, $offset, $zmmKeys, $zmmData) = @_; # Block multi way tree descriptor, offset as a variable, numbered zmm for keys, numbered data for keys @_ == 4 or confess; my $b = $bmt->bs; # Underlying byte string $b->getBlock($b->bs, $offset, $zmmKeys); # Get the keys block my $data = $bmt->getLoop($zmmKeys); # Get the offset of the corresponding data block $b->getBlock($b->bs, $data, $zmmData); # Get the data block } sub Nasm::X86::BlockMultiWayTree::putKeysData($$$$) # Save the key and data blocks for a node {my ($bmt, $offset, $zmmKeys, $zmmData) = @_; # Block multi way tree descriptor, offset as a variable, numbered zmm for keys, numbered data for keys @_ == 4 or confess; my $b = $bmt->bs; # Underlying byte string $b->putBlock($b->bs, $offset, $zmmKeys); # Put the keys block my $data = $bmt->getLoop($zmmKeys); # Get the offset of the corresponding data block my $up = $bmt->getUpFromData($zmmData); #DEBUG Check up pointer If ($up >= $offset, sub {PrintErrStringNL "Up is not less than node"; Exit(0); }); $b->putBlock($b->bs, $data, $zmmData); # Put the data block } sub Nasm::X86::BlockMultiWayTree::getNode($$$) # Load the child nodes for a node {my ($bmt, $offset, $zmmNode) = @_; # Block multi way tree descriptor, offset of nodes, numbered zmm for keys @_ == 3 or confess; $bmt->bs->getBlock($bmt->bs->bs, $offset, $zmmNode); # Get the node block } sub Nasm::X86::BlockMultiWayTree::getKeysDataNode($$$$$) # Load the keys, data and child nodes for a node {my ($bmt, $offset, $zmmKeys, $zmmData, $zmmNode) = @_; # Block multi way tree descriptor, offset as a variable, numbered zmm for keys, numbered data for keys, numbered numbered for keys @_ == 5 or confess; my $b = $bmt->bs; # Underlying byte string $b->getBlock($b->bs, $offset, $zmmKeys); # Get the keys block my $data = $bmt->getLoop($zmmKeys); # Get the offset of the corresponding data block $b->getBlock($b->bs, $data, $zmmData); # Get the data block my $node = $bmt->getLoop($zmmData); # Get the offset of the corresponding node block If ($node, sub # Check for optional node block {$b->getBlock($b->bs, $node, $zmmNode); # Get the node block }, sub # No children {ClearRegisters zmm $zmmNode; # Clear the child block to signal that there was not one - if there were it would have child nodes in it which would be none zero }); } sub Nasm::X86::BlockMultiWayTree::putKeysDataNode($$$$$) # Save the keys, data and child nodes for a node {my ($bmt, $offset, $zmmKeys, $zmmData, $zmmNode) = @_; # Block multi way tree descriptor, offset as a variable, numbered zmm for keys, numbered data for keys, numbered numbered for keys @_ == 5 or confess; $bmt->putKeysData($offset, $zmmKeys, $zmmData); # Put keys and data my $node = $bmt->getLoop($zmmData); # Get the offset of the corresponding node block If ($node, sub # Check for optional node block {$bmt->bs->putBlock($bmt->bs->bs, $node, $zmmNode); # Put the node block }); } sub Nasm::X86::BlockMultiWayTree::getLengthInKeys($$) # Get the length of the keys block in the numbered zmm and return it as a variable {my ($bmt, $zmm) = @_; # Block multi way tree descriptor, zmm number @_ == 2 or confess; getDFromZmm($zmm, $bmt->length); # The length field as a variable } sub Nasm::X86::BlockMultiWayTree::putLengthInKeys($$$) # Get the length of the block in the numbered zmm from the specified variable {my ($bmt, $zmm, $length) = @_; # Block multi way tree, zmm number, length variable @_ == 3 or confess; ref($length) or confess dump($length); $length->putDIntoZmm($zmm, $bmt->length); # Set the length field } sub Nasm::X86::BlockMultiWayTree::getUpFromData($$) # Get the up offset from the data block in the numbered zmm and return it as a variable {my ($bmt, $zmm) = @_; # Block multi way tree descriptor, zmm number @_ == 2 or confess; getDFromZmm($zmm, $bmt->length); # The length field as a variable } sub Nasm::X86::BlockMultiWayTree::putUpIntoData($$$) # Put the offset of the parent keys block expressed as a variable into the numbered zmm {my ($bmt, $offset, $zmm) = @_; # Block multi way tree descriptor, variable containing up offset, zmm number @_ == 3 or confess; defined($offset) or confess; $offset->putDIntoZmm($zmm, $bmt->length); # Save the up offset into the data block } sub Nasm::X86::BlockMultiWayTree::getLoop($$) # Return the value of the loop field as a variable {my ($bmt, $zmm) = @_; # Block multi way tree descriptor, numbered zmm @_ >= 1 or confess; getDFromZmm($zmm, $bmt->loop); # Get loop field as a variable } sub Nasm::X86::BlockMultiWayTree::putLoop($$$) # Set the value of the loop field from a variable {my ($bmt, $value, $zmm) = @_; # Block multi way tree descriptor, variable containing offset of next loop entry, numbered zmm @_ >= 1 or confess; $value->putDIntoZmm($zmm, $bmt->loop); # Put loop field as a variable } sub Nasm::X86::BlockMultiWayTree::leftOrRightMost($$@) # Return the left most or right most node {my ($bmt, $dir, @variables) = @_; # Block multi way tree descriptor, direction: left = 0 or right = 1, variables @_ >= 1 or confess; my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $b = $bmt->bs; # Underlying byte string my $s = Subroutine {my ($p) = @_; # Parameters my $B = $$p{bs}; # Byte string my $F = $$p{node}; # First block PushR my @save = (rax, zmm29, zmm30, zmm31); Cq(loopLimit, 9)->for(sub # Loop a reasonable number of times {my ($index, $start, $next, $end) = @_; $bmt->getKeysDataNode($F, 31, 30, 29); # Get the first keys block my $n = getDFromZmm(29, 0); # Get the node block offset from the data block loop If ($n == 0, sub # Reached the end so return the containing block {$$p{offset}->copy($F); Jmp $success; }); if ($dir == 0) # Left most {my $l = getDFromZmm(29, 0); # Get the left most node $F->copy($l); # Continue with the next level } else # Right most {my $l = $bmt->getLengthInKeys(31); # Length of the node my $r = getDFromZmm(31, $l); # Get the right most child $F->copy($r); # Continue with the next level } }); PrintErrStringNL "Stuck in LeftOrRightMost"; Exit(1); SetLabel $success; # Insert completed successfully PopR @save; } name => $dir == 0 ? "Nasm::X86::BlockMultiWayTree::leftMost" : "Nasm::X86::BlockMultiWayTree::rightMost", in => {bs => 3, node => 3}, out => {offset => 3}; $s->call($bmt->address, @variables); } sub Nasm::X86::BlockMultiWayTree::leftMost($@) # Return the left most node {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables $bmt->leftOrRightMost(0, @variables) # Return the left most node } sub Nasm::X86::BlockMultiWayTree::rightMost($@) # Return the right most node {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables $bmt->leftOrRightMost(1, @variables) # Return the right most node } sub Nasm::X86::BlockMultiWayTree::nodeFromData($$$) # Load the the node block into the numbered zmm corresponding to the data block held in the numbered zmm. {my ($bmt, $data, $node) = @_; # Block multi way tree descriptor, numbered zmm containing data, numbered zmm to hold node block @_ == 3 or confess; my $loop = $bmt->getLoop($data); # Get loop offset from data $bmt->getBlock($bmt->address, $loop, $node); # Node } sub Nasm::X86::BlockMultiWayTree::address($) # Address of the byte string containing a block multi way tree {my ($bmt) = @_; # Block multi way tree descriptor @_ == 1 or confess; $bmt->bs->bs; } sub Nasm::X86::BlockMultiWayTree::allocBlock($@) # Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables @_ == 1 or confess; $bmt->bs->allocBlock # Allocate a block and return its offset as a variable } sub Nasm::X86::BlockMultiWayTree::depth($@) # Return the depth of a node within a tree. {my ($bmt, @variables) = @_; # Block multi way tree descriptor, variables @_ >= 2 or confess; my $s = Subroutine {my ($parameters) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $B = $$parameters{bs}; # Byte string my $N = $$parameters{node}; # Starting node PushR my @save = (r14, r15, zmm30, zmm31); my $tree = $N->clone; # Start at the specified node Cq(loop, 9)->for(sub # Step up through tree {my ($index, $start, $next, $end) = @_; $bmt->getKeysData($tree, 31, 30); # Get the keys block my $p = $bmt->getUpFromData(30); # Parent If ($p == 0, sub # Empty tree so we have not found the key {$$parameters{depth}->copy($index+1); # Key not found Jmp $success; # Return }); $tree->copy($p); # Up to next level }); PrintErrStringNL "Stuck in depth"; # We seem to be looping endlessly Exit(1); SetLabel $success; # Insert completed successfully PopR @save; } in => {bs => 3, node => 3}, out => {depth => 3}; $s->call($bmt->address, @variables); } # depth sub Nasm::X86::BlockMultiWayTree::iterator($) # Iterate through a multi way tree {my ($b) = @_; # Block multi way tree @_ == 1 or confess; my $node = Vq(node); # The current node $node->copy($b->first); # Start at the first node in the tree my $i = genHash(__PACKAGE__.'::BlockMultiWayTree::Iterator', # Iterator tree => $b, # Tree we are iterating over node => $node, # Current node within tree pos => Vq('pos'), # Current position within node key => Vq(key), # Key at this position data => Vq(data), # Data at this position count => Vq(count), # Counter - number of node more => Vq(more), # Iteration not yet finished ); $i->pos ->copy(Vq('pos', -1)); # Initialize iterator $i->count->copy(Vq(count, 0)); $i->more ->copy(Vq(more, 1)); $i->next; # First element if any } sub Nasm::X86::BlockMultiWayTree::Iterator::next($) # Next element in the tree {my ($iter) = @_; # Iterator @_ == 1 or confess; my $s = Subroutine {my ($p) = @_; # Parameters my $success = Label; # Short circuit if ladders by jumping directly to the end after a successful push my $C = $$p{node}; # Current node required $$p{count} = $$p{count} + 1; # Count the calls to the iterator my $new = sub # Load iterator with latest position {my ($node, $pos) = @_; # Parameters PushR my @save = (zmm31, zmm30, zmm29); $$p{node}->copy($node); # Set current node $$p{pos} ->copy($pos); # Set current position in node $iter->tree->getKeysData($node, 31, 30); # Load keys and data my $offset = $pos * $iter->tree->width; # Load key and data $$p{key} ->copy(getDFromZmm(31, $offset)); $$p{data}->copy(getDFromZmm(30, $offset)); PopR @save; }; my $done = sub # The tree has been completely traversed {PushR rax; Mov rax, 0; $$p{more}->getReg(rax); PopR rax; }; If ($$p{pos} == -1, sub # Initial descent {my $t = $iter->tree; PushR my @save = (zmm31, zmm30, zmm29); $t->getKeysDataNode($C, 31, 30, 29); # Load keys and data my $nodes = $t->getLoop(30); # Nodes If ($nodes, sub # Go left if there are child nodes {$t->leftMost($t->address, $C, my $l = Vq(offset)); &$new($l, Cq(zero, 0)); }, sub {my $l = $t->getLengthInKeys(31); # Number of keys If ($l, sub # Start with the current node as it is a leaf {&$new($C, Cq(zero, 0)); }, sub {&$done; }); }); PopR @save; Jmp $success; # Return with iterator loaded }); my $up = sub # Iterate up to next node that has not been visited {my $top = Label; # Reached the top of the tree my $n = $C->clone; my $zmmNK = 31; my $zmmPK = 28; my $zmmTest = 25; my $zmmND = 30; my $zmmPD = 27; my $zmmNN = 29; my $zmmPN = 26; PushR my @save = (k7, r14, r15, map {"zmm$_"} 25..31); my $t = $iter->tree; ForEver # Up through the tree {my ($start, $end) = @_; # Parameters $t->getKeysData($n, $zmmNK, $zmmND); # Load keys and data for current node my $p = $t->getUpFromData($zmmND); If ($p == 0, sub{Jmp $end}); # Jump to the end if we have reached the top of the tree $t->getKeysDataNode($p, $zmmPK, $zmmPD, $zmmPN); # Load keys, data and children nodes for parent which must have children $n->setReg(r15); # Offset of child Vpbroadcastd "zmm".$zmmTest, r15d; # Current node broadcasted Vpcmpud k7, "zmm".$zmmPN, "zmm".$zmmTest, 0; # Check for equal offset - one of them will match to create the single insertion point in k6 Kmovw r14d, k7; # Bit mask ready for count Tzcnt r14, r14; # Number of leading zeros gives us the position of the child in the parent my $i = Vq(indexInParent, r14); # Index in parent my $l = $t->getLengthInKeys($zmmPK); # Length of parent If ($i < $l, sub # Continue with this node if all the keys have yet to be finished {&$new($p, $i); Jmp $top; }); $n->copy($p); # Continue with parent }; &$done; # No nodes not visited SetLabel $top; PopR @save; }; $$p{pos}->copy(my $i = $$p{pos} + 1); # Next position in block being scanned PushR my @save = (zmm31, zmm30, zmm29); $iter->tree->getKeysDataNode($C, 31, 30, 29); # Load keys and data my $l = $iter->tree->getLengthInKeys(31); # Length of keys my $n = getDFromZmm(29, 0); # First node will ne zero if on a leaf If ($n == 0, sub # Leaf {If ($i < $l, sub {&$new($C, $i); }, sub {&$up; }); }, sub # Node {my $offsetAtI = getDFromZmm(29, $i * $iter->tree->width); $iter->tree->leftMost(node=>$offsetAtI, my $l = Vq(offset)); &$new($l, Cq(zero, 0)); }); PopR @save; SetLabel $success; } io => {node => 3, pos => 3, key => 3, data => 3, count => 3, more => 3}; $s->call($iter->node, $iter->pos, $iter->key, # Call with iterator variables $iter->data, $iter->count, $iter->more); $iter # Return the iterator } sub Nasm::X86::BlockMultiWayTree::by($&) # Call the specified body with each (key, data) from the specified tree in order {my ($b, $body) = @_; # Block Multi Way Tree descriptor, body @_ == 2 or confess; my $iter = $b->iterator; # Create an iterator my $start = SetLabel Label; my $end = Label; # Start and end of loop If ($iter->more == 0, sub {Jmp $end}); # Jump to end if there are no more elements to process &$body($iter, $end); # Perform the body parameterized by the iterator and the end label $iter->next; # Next element Jmp $start; # Process next element SetLabel $end; # End of the loop } #D1 Assemble # Assemble generated code sub CallC($@) # Call a C subroutine {my ($sub, @parameters) = @_; # Name of the sub to call, parameters my @order = (rdi, rsi, rdx, rcx, r8, r9, r15); PushR @order; for my $i(keys @parameters) # Load parameters into designated registers {Mov $order[$i], $parameters[$i]; } Push rax; # Align stack on 16 bytes Mov rax, rsp; # Move stack pointer Shl rax, 60; # Get lowest nibble Shr rax, 60; KeepFree rax; IfEq # If we are 16 byte aligned push two twos {Mov rax, 2; Push rax; Push rax; KeepFree rax; } sub # If we are not 16 byte aligned push one one. {Mov rax, 1; Push rax; KeepFree rax; }; if (ref($sub)) # ? {Call $sub->start; } else # Call named subroutine {Call $sub; } Pop r15; # Decode and reset stack after 16 byte alignment Cmp r15, 2; # Check for double push Pop r15; # Single or double push IfEq {Pop r15}; # Double push PopR @order; } sub Extern(@) # Name external references {my (@externalReferences) = @_; # External references push @extern, @_; } sub Link(@) # Libraries to link with {my (@libraries) = @_; # External references push @link, @_; } sub Start() # Initialize the assembler {@bss = @data = @rodata = %rodata = %rodatas = %subroutines = @text = %Keep = %KeepStack = @extern = @link = (); $Labels = 0; $ScopeCurrent = undef; } sub Exit(;$) # Exit with the specified return code or zero if no return code supplied. Assemble() automatically adds a call to Exit(0) if the last operation in the program is not a call to Exit. {my ($c) = @_; # Return code PushR my @save = (rax, rdi); if (@_ == 0 or $c == 0) {Comment "Exit code: 0"; KeepFree rdi; Mov rdi, 0; } elsif (@_ == 1) {Comment "Exit code: $c"; KeepFree rdi; Mov rdi, $c; } Mov rax, 60; Syscall; PopR @save; } my $LocateIntelEmulator; # Location of Intel Software Development Emulator sub LocateIntelEmulator() #P Locate the Intel Software Development Emulator {my @locations = qw(/var/isde/sde64 sde/sde64 ./sde64); # Locations at which we might find the emulator my $downloads = q(/home/phil/Downloads); # Downloads folder return $LocateIntelEmulator if defined $LocateIntelEmulator; # Location has already been discovered for my $l(@locations) # Try each locations {return $LocateIntelEmulator = $l if -e $l; # Found it - cache and return } if (qx(sde64 -version) =~ m(Intel.R. Software Development Emulator)) # Try path {return $LocateIntelEmulator = "sde64"; } return undef unless -e $downloads; # Skip local install if not developing my $install = < sde.tar.bz2 tar -xf sde.tar.bz2 sudo mkdir -p /var/isde/ sudo cp -r * /var/isde/ ls -ls /var/isde/ END say STDERR qx($install); # Execute install for my $l(@locations) # Retry install locations after install {return $LocateIntelEmulator = $l if -e $l; # Found it - cache and return } undef # Still not found - give up } my $assembliesPerformed = 0; # Number of assemblies performed my $totalBytesAssembled = 0; # Estimate the size of the output programs sub Assemble(%) # Assemble the generated code {my (%options) = @_; # Options Exit 0 unless @text > 4 and $text[-4] =~ m(Exit code:); # Exit with code 0 if no other exit has been taken my $debug = $options{debug}//0; # 0 - none (minimal output), 1 - normal (debug output and confess of failure), 2 - failures (debug output and no confess on failure) . my $k = $options{keep}; # Keep the executable my $r = join "\n", map {s/\s+\Z//sr} @rodata; my $d = join "\n", map {s/\s+\Z//sr} @data; my $b = join "\n", map {s/\s+\Z//sr} @bss; my $t = join "\n", map {s/\s+\Z//sr} @text; my $x = join "\n", map {qq(extern $_)} @extern; my $L = join " ", map {qq(-l$_)} @link; my $a = <"executable file name") (2) Assemble(emulator=>0) END $emulator = 0; } my $I = @link ? $interpreter : ''; # Interpreter only required if calling C my $cmd = qq(nasm -f elf64 -g -l $l -o $o $c && ld $I $L -o $e $o && chmod 744 $e);# Assemble my $o1 = 'zzzOut.txt'; my $o2 = 'zzzErr.txt'; my $o3 = 'zzzTrace.txt'; my $o3a = 'zzzTraceA.txt'; # Trace file and previous trace file unlink $o1, $o2, $o2; # Remove output files my $out = $k ? '' : "1>$o1"; my $err = $k ? '' : "2>$o2"; my $trc = "3>$o3"; my $exec = $emulator # Execute with or without the emulator ? qq($sde -ptr-check -- ./$e $err $out $trc) : qq(./$e $err $out $trc); $cmd .= qq( && $exec) unless $k; # Execute automatically unless suppressed by user $assembliesPerformed++; say STDERR qq($assembliesPerformed: $cmd); my $R = qx($cmd); # Assemble and perhaps run if (!$k and $debug > 0 and -e $o3) # Last trace {if (my @l = readFile $o3) {say STDERR "Last trace: ", $l[-1] if @l; if (-e $o3a) # Compare with last trace {if (my @m = readFile $o3a) {while (@l and @m and $l[0] == $m[0]) # Remove common prefix {shift @l; shift @m; } if (@m) # Remove point of departure {say STDERR "This run went to: ".$l[0] if @l; say STDERR "Prior run went to: ".$m[0] if @m; } } } else # Copy trace to back up trace if no back up trace present {rename $o3, $o3a; } } } if (!$k and $debug == 0) # Print errors if not debugging {say STDERR readFile($o2); } if (!$k and $debug == 1) # Print files if soft debugging {say STDERR readFile($o1) =~ s(0) ( )gsr; say STDERR readFile($o2); } confess "Failed $?" if $debug < 2 and $?; # Check that the assembly succeeded if (!$k and $debug < 2 and -e $o2 and readFile($o2) =~ m(SDE ERROR:)s) # Emulator detected an error {confess "SDE ERROR\n".readFile($o2); } $totalBytesAssembled += fileSize $c; # Estimate the size of the output programs unlink $o; # Delete files unlink $e unless $k; # Delete executable unless asked to keep it $totalBytesAssembled += fileSize $c; # Estimate the size of the output program Start; # Clear work areas for next assembly return $exec if $k; # Executable wanted if (defined(my $e = $options{eq})) # Diff against expected {my $g = readFile($debug < 2 ? $o1 : $o2); if ($g ne $e) {my ($s, $G, $E) = stringsAreNotEqual($g, $e); if (length($s)) {my $line = 1 + length($s =~ s([^\n]) ()gsr); my $char = 1 + length($s =~ s(\A.*\n) ()sr); say STDERR "Comparing wanted with got failed at line: $line, character: $char"; say STDERR "Start:\n$s"; } my $b1 = '+' x 80; my $b2 = '_' x 80; say STDERR "Want $b1\n", firstNChars($E, 80); say STDERR "Got $b2\n", firstNChars($G, 80); say STDERR "Want: ", dump($e); say STDERR "Got : ", dump($g); confess "Test failed"; # Test failed unless we are debugging test failures } return 1; # Test passed } scalar(readFile($debug < 2 ? $o1 : $o2)); # stdout results unless stderr results requested } sub removeNonAsciiChars($) #P Return a copy of the specified string with all the non ascii characters removed {my ($string) = @_; # String $string =~ s([^a-z0..9]) ()igsr; # Remove non ascii characters } sub totalBytesAssembled #P Total size in bytes of all files assembled during testing {$totalBytesAssembled } #d #------------------------------------------------------------------------------- # Export - eeee #------------------------------------------------------------------------------- if (0) # Print exports {my @e; for my $a(sort keys %Nasm::X86::) {next if $a =~ m(BAIL_OUT|BEGIN|DATA|confirmHasCommandLineCommand|currentDirectory|fff|fileMd5Sum|fileSize|findFiles|firstNChars|formatTable|fpe|fpf|genHash|lll|owf|pad|readFile|stringsAreNotEqual|stringMd5Sum|temporaryFile); next if $a =~ m(\AEXPORT); next if $a !~ m(\A[A-Z]) and !$Registers{$a}; next if $a =~ m(::\Z); push @e, $a if $Nasm::X86::{$a} =~ m(\*Nasm::X86::); } say STDERR q/@EXPORT_OK = qw(/.join(' ', @e).q/);/; exit; } use Exporter qw(import); use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); @ISA = qw(Exporter); @EXPORT = qw(); @EXPORT_OK = qw(Add All8Structure AllocateAll8OnStack AllocateMemory And Assemble Block Bswap Bt Btc Btr Bts Bzhi Call CallC ClassifyCharacters4 ClassifyInRange ClassifyRange ClassifyWithInRange ClassifyWithInRangeAndSaveOffset ClearMemory ClearRegisters ClearZF CloseFile Cmova Cmovae Cmovb Cmovbe Cmovc Cmove Cmovg Cmovge Cmovl Cmovle Cmovna Cmovnae Cmovnb Cmp Comment ConcatenateShortStrings ConvertUtf8ToUtf32 CopyMemory Cq CreateByteString Cstrlen DComment Db Dbwdq Dd Dec Dq Ds Dw Else Exit Extern Float32 Float64 For ForEver ForIn Fork FreeMemory GetLengthOfShortString GetNextUtf8CharAsUtf32 GetPPid GetPid GetPidInHex GetUid Hash ISA Idiv If IfEq IfGe IfGt IfLe IfLt IfNe IfNz IfZ Imul Inc Ja Jae Jb Jbe Jc Jcxz Je Jecxz Jg Jge Jl Jle Jmp Jna Jnae Jnb Jnbe Jnc Jne Jng Jnge Jnl Jnle Jno Jnp Jns Jnz Jo Jp Jpe Jpo Jrcxz Js Jz Kaddb Kaddd Kaddq Kaddw Kandb Kandd Kandnb Kandnd Kandnq Kandnw Kandq Kandw Keep KeepFree KeepPop KeepPush KeepReturn KeepSet Kmovb Kmovd Kmovq Kmovw Knotb Knotd Knotq Knotw Korb Kord Korq Kortestb Kortestd Kortestq Kortestw Korw Kshiftlb Kshiftld Kshiftlq Kshiftlw Kshiftrb Kshiftrd Kshiftrq Kshiftrw Ktestb Ktestd Ktestq Ktestw Kunpckb Kunpckd Kunpckq Kunpckw Kxnorb Kxnord Kxnorq Kxnorw Kxorb Kxord Kxorq Kxorw Label Lea Link LoadConstantIntoMaskRegister LoadShortStringFromMemoryToZmm LoadShortStringFromMemoryToZmm2 LocalData LocateIntelEmulator Lzcnt Macro MaskMemory MaskMemoryInRange4 MatchBrackets Mov Movdqa Mulpd Neg Not OpenRead OpenWrite Or PeekR Pextrb Pextrd Pextrq Pextrw Pi32 Pi64 Pinsrb Pinsrd Pinsrq Pinsrw Pop PopEax PopR PopRR Popcnt Popfq PrintErrMemory PrintErrMemoryInHex PrintErrMemoryInHexNL PrintErrMemoryNL PrintErrNL PrintErrRaxInHex PrintErrRegisterInHex PrintErrString PrintErrStringNL PrintErrZF PrintMemory PrintMemoryInHex PrintNL PrintOutMemory PrintOutMemoryInHex PrintOutMemoryInHexNL PrintOutMemoryNL PrintOutNL PrintOutRaxInHex PrintOutRaxInReverseInHex PrintOutRegisterInHex PrintOutRegistersInHex PrintOutRflagsInHex PrintOutRipInHex PrintOutString PrintOutStringNL PrintOutZF PrintRaxInHex PrintRegisterInHex PrintString PrintUtf32 Pslldq Psrldq Push PushR PushRR Pushfq RComment Rb Rbwdq Rd Rdtsc ReadFile ReadTimeStampCounter RegisterSize ReorderSyscallRegisters RestoreFirstFour RestoreFirstFourExceptRax RestoreFirstFourExceptRaxAndRdi RestoreFirstSeven RestoreFirstSevenExceptRax RestoreFirstSevenExceptRaxAndRdi Ret Rq Rs Rutf8 Rw SaveFirstFour SaveFirstSeven Scope ScopeEnd SetLabel SetLengthOfShortString SetMaskRegister SetZF Seta Setae Setb Setbe Setc Sete Setg Setge Setl Setle Setna Setnae Setnb Setnbe Setnc Setne Setng Setnge Setnl Setno Setnp Setns Setnz Seto Setp Setpe Setpo Sets Setz Shl Shr Start StatSize StringLength Structure Sub Subroutine Syscall Test Then Trace Tzcnt UnReorderSyscallRegisters VERSION Vaddd Vaddpd Variable Vb Vcvtudq2pd Vcvtudq2ps Vcvtuqq2pd Vd Vdpps Vgetmantps Vmovd Vmovdqa32 Vmovdqa64 Vmovdqu Vmovdqu32 Vmovdqu64 Vmovdqu8 Vmovq Vmulpd Vpbroadcastb Vpbroadcastd Vpbroadcastq Vpbroadcastw Vpcmpeqb Vpcmpeqd Vpcmpeqq Vpcmpeqw Vpcmpub Vpcmpud Vpcmpuq Vpcmpuw Vpcompressd Vpcompressq Vpexpandd Vpexpandq Vpextrb Vpextrd Vpextrq Vpextrw Vpinsrb Vpinsrd Vpinsrq Vpinsrw Vpmullb Vpmulld Vpmullq Vpmullw Vprolq Vpsubb Vpsubd Vpsubq Vpsubw Vpxorq Vq Vr Vsqrtpd Vw Vx VxyzInit Vy Vz WaitPid Xchg Xor ah al ax bh bl bp bpl bx ch cl cs cx dh di dil dl ds dx eax ebp ebx ecx edi edx es esi esp fs gs k0 k1 k2 k3 k4 k5 k6 k7 mm0 mm1 mm2 mm3 mm4 mm5 mm6 mm7 r10 r10b r10d r10l r10w r11 r11b r11d r11l r11w r12 r12b r12d r12l r12w r13 r13b r13d r13l r13w r14 r14b r14d r14l r14w r15 r15b r15d r15l r15w r8 r8b r8d r8l r8w r9 r9b r9d r9l r9w rax rbp rbx rcx rdi rdx rflags rip rsi rsp si sil sp spl ss st0 st1 st2 st3 st4 st5 st6 st7 xmm0 xmm1 xmm10 xmm11 xmm12 xmm13 xmm14 xmm15 xmm16 xmm17 xmm18 xmm19 xmm2 xmm20 xmm21 xmm22 xmm23 xmm24 xmm25 xmm26 xmm27 xmm28 xmm29 xmm3 xmm30 xmm31 xmm4 xmm5 xmm6 xmm7 xmm8 xmm9 ymm0 ymm1 ymm10 ymm11 ymm12 ymm13 ymm14 ymm15 ymm16 ymm17 ymm18 ymm19 ymm2 ymm20 ymm21 ymm22 ymm23 ymm24 ymm25 ymm26 ymm27 ymm28 ymm29 ymm3 ymm30 ymm31 ymm4 ymm5 ymm6 ymm7 ymm8 ymm9 zmm0 zmm1 zmm10 zmm11 zmm12 zmm13 zmm14 zmm15 zmm16 zmm17 zmm18 zmm19 zmm2 zmm20 zmm21 zmm22 zmm23 zmm24 zmm25 zmm26 zmm27 zmm28 zmm29 zmm3 zmm30 zmm31 zmm4 zmm5 zmm6 zmm7 zmm8 zmm9); %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]); # podDocumentation =pod =encoding utf-8 =head1 Name Nasm::X86 - Generate X86 assembler code using Perl as a macro pre-processor. =head1 Synopsis Write and execute x64 instructions using Perl as a macro assembler as shown in the following examples. =head2 Examples =head3 Avx512 instructions Use avx512 instructions to do 64 comparisons in parallel: my $P = "2F"; # Value to test for my $l = Rb 0; Rb $_ for 1..RegisterSize zmm0; # 0..63 Vmovdqu8 zmm0, "[$l]"; # Load data to test PrintOutRegisterInHex zmm0; Mov rax, "0x$P"; # Broadcast the value to be tested Vpbroadcastb zmm1, rax; PrintOutRegisterInHex zmm1; for my $c(0..7) # Each possible test {my $m = "k$c"; Vpcmpub $m, zmm1, zmm0, $c; PrintOutRegisterInHex $m; } Kmovq rax, k0; # Count the number of trailing zeros in k0 Tzcnt rax, rax; PrintOutRegisterInHex rax; is_deeply Assemble, <q('aa'); $b->q('bb'); $a->q('AA'); $b->q('BB'); $a->q('aa'); $b->q('bb'); $a->out; $b->out; PrintOutNL; is_deeply Assemble, <setReg(rax); # Address of file in memory $s->setReg(rdi); # Length of file in memory PrintOutMemory; # Print contents of memory to stdout my $r = Assemble(1 => (my $f = temporaryFile)); # Assemble and execute ok fileMd5Sum($f) eq fileMd5Sum($0); # Output contains this file =head3 Call functions in Libc Call B functions by naming them as external and including their library: my $format = Rs "Hello %s\n"; my $data = Rs "World"; Extern qw(printf exit malloc strcpy); Link 'c'; CallC 'malloc', length($format)+1; Mov r15, rax; CallC 'strcpy', r15, $format; CallC 'printf', r15, $data; CallC 'exit', 0; ok Assemble(eq => < The Networkwide Assembler is required to assemble the code produced For full details see: L =head2 Execution Options The L function takes the keywords described below to control assembly and execution of the assembled code: L runs the generated program after a successful assembly unless the B option is specified. The output on B is captured in file B and that on B is captured in file B. The amount of output displayed is controlled by the B keyword. The B keyword can be used to test that the output by the run. The output produced by the program execution is returned as the result of the L function. =head3 Keep To produce a named executable without running it, specify: keep=>"executable file name" =head3 Emulator To run the executable produced by L without the Intel emulator, which is used by default if it is present, specify: emulator=>0 =head3 eq The B keyword supplies the expected output from the execution of the assembled program. If the expected output is not obtained on B then we confess and stop further testing. Output on B is ignored for test purposes. The point at which the wanted output diverges from the output actually got is displayed to assist debugging as in: Comparing wanted with got failed at line: 4, character: 22 Start: k7: 0000 0000 0000 0001 k6: 0000 0000 0000 0003 k5: 0000 0000 0000 0007 k4: 0000 0000 000 Want ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 0002 k3: 0000 0000 0000 0006 k2: 0000 0000 0000 000E k1: 0000 0000 Got ________________________________________________________________________________ 0 0002 k3: 0000 0000 0000 0006 k2: 0000 0000 0000 000E k1: 0000 0000 =head3 Debug The debug keyword controls how much output is printed after each assemble and run. debug => 0 produces no output unless the B keyword was specified and the actual output fails to match the expected output. If such a test fails we L. debug => 1 shows all the output produces and conducts the test specified by the B is present. If the test fails we L. debug => 2 shows all the output produces and conducts the test specified by the B is present. If the test fails we continue rather than calling L. =head1 Description Generate X86 assembler code using Perl as a macro pre-processor. Version "20210728". The following sections describe the methods in each functional area of this module. For an alphabetic listing of all methods by name see L. =head1 Data Layout data =head2 SetLabel($l) Set a label in the code section Parameter Description 1 $l Label B Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply Assemble, < my $q = Rs('a'..'z'); Mov rax, Ds('0'x64); # Output area # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu32(xmm0, "[$q]"); # Load Vprolq (xmm0, xmm0, 32); # Rotate double words in quad words Vmovdqu32("[rax]", xmm0); # Save Mov rdi, 16; PrintOutMemory; ok Assemble =~ m(efghabcdmnopijkl)s; =head2 Rs(@d) Layout bytes in read only memory and return their label Parameter Description 1 @d Data to be laid out B Comment "Print a string from memory"; my $s = "Hello World"; Mov rax, Rs($s); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rdi, length $s; PrintOutMemory; ok Assemble =~ m(Hello World); my $q = Rs('abababab'); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov(rax, 1); Mov(rbx, 2); Mov(rcx, 3); Mov(rdx, 4); Mov(r8, 5); Lea r9, "[rax+rbx]"; PrintOutRegistersInHex; my $r = Assemble; ok $r =~ m( r8: 0000 0000 0000 0005.* r9: 0000 0000 0000 0003.*rax: 0000 0000 0000 0001)s; ok $r =~ m(rbx: 0000 0000 0000 0002.*rcx: 0000 0000 0000 0003.*rdx: 0000 0000 0000 0004)s; =head2 Rutf8(@d) Layout a utf8 encoded string as bytes in read only memory and return their label Parameter Description 1 @d Data to be laid out =head2 Db(@bytes) Layout bytes in the data segment and return their label Parameter Description 1 @bytes Bytes to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Dw(@words) Layout words in the data segment and return their label Parameter Description 1 @words Words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Dd(@dwords) Layout double words in the data segment and return their label Parameter Description 1 @dwords Double words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Dq(@qwords) Layout quad words in the data segment and return their label Parameter Description 1 @qwords Quad words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Rb(@bytes) Layout bytes in the data segment and return their label Parameter Description 1 @bytes Bytes to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Rw(@words) Layout words in the data segment and return their label Parameter Description 1 @words Words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Rd(@dwords) Layout double words in the data segment and return their label Parameter Description 1 @dwords Double words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Rq(@qwords) Layout quad words in the data segment and return their label Parameter Description 1 @qwords Quad words to layout B my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); =head2 Float32($float) 32 bit float Parameter Description 1 $float Float =head2 Float64($float) 64 bit float Parameter Description 1 $float Float =head1 Registers Operations on registers =head2 xmm(@r) Add xmm to the front of a list of register expressions Parameter Description 1 @r Register numbers =head2 ymm(@r) Add ymm to the front of a list of register expressions Parameter Description 1 @r Register numbers =head2 zmm(@r) Add zmm to the front of a list of register expressions Parameter Description 1 @r Register numbers =head2 Save and Restore Saving and restoring registers via the stack =head3 SaveFirstFour(@keep) Save the first 4 parameter registers making any parameter registers read only Parameter Description 1 @keep Registers to mark as read only B Mov rax, 1; Mov rdi, 1; SaveFirstFour; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax, 1; Mov rdi, 2; Mov rsi, 3; Mov rdx, 4; Mov r8, 8; Mov r9, 9; Mov r10, 10; Mov r11, 11; ReorderSyscallRegisters r8,r9; # Reorder the registers for syscall # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; PrintOutRegisterInHex rdi; UnReorderSyscallRegisters r8,r9; # Unreorder the registers to recover their original values PrintOutRegisterInHex rax; PrintOutRegisterInHex rdi; ok Assemble =~ m(rax:.*08.*rdi:.*9.*rax:.*1.*rdi:.*2.*)s; =head3 UnReorderSyscallRegisters(@registers) Recover the initial values in registers that were reordered Parameter Description 1 @registers Registers B Mov rax, 1; Mov rdi, 2; Mov rsi, 3; Mov rdx, 4; Mov r8, 8; Mov r9, 9; Mov r10, 10; Mov r11, 11; ReorderSyscallRegisters r8,r9; # Reorder the registers for syscall PrintOutRegisterInHex rax; PrintOutRegisterInHex rdi; UnReorderSyscallRegisters r8,r9; # Unreorder the registers to recover their original values # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; PrintOutRegisterInHex rdi; ok Assemble =~ m(rax:.*08.*rdi:.*9.*rax:.*1.*rdi:.*2.*)s; =head3 RegisterSize($r) Return the size of a register Parameter Description 1 $r Register B Mov rax, 1; Mov rdi, 1; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSeven; PrintOutRegisterInHex rax, rdi; RestoreFirstFour; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRax; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRax; PrintOutRegisterInHex rax, rdi; SaveFirstFour; Mov rax, 2; Mov rdi, 2; SaveFirstSeven; Mov rax, 3; Mov rdi, 4; PrintOutRegisterInHex rax, rdi; RestoreFirstSevenExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; RestoreFirstFourExceptRaxAndRdi; PrintOutRegisterInHex rax, rdi; Bswap rax; PrintOutRegisterInHex rax; my $l = Label; Jmp $l; SetLabel $l; is_deeply Assemble, < Mov rax,1; Kmovq k0, rax; Kaddb k0, k0, k0; Kaddb k0, k0, k0; Kaddb k0, k0, k0; Kmovq rax, k0; PushR k0; ClearRegisters k0; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Kmovq k1, k0; PopR k0; PrintOutRegisterInHex k0; PrintOutRegisterInHex k1; ok Assemble =~ m(k0: 0000 0000 0000 0008.*k1: 0000 0000 0000 0000)s; =head3 SetMaskRegister($mask, $start, $length) Set the mask register to ones starting at the specified position for the specified length and zeroes elsewhere Parameter Description 1 $mask Mask register to set 2 $start Register containing start position or 0 for position 0 3 $length Register containing end position B Mov rax, 8; Mov rsi, -1; Inc rsi; SetMaskRegister(k0, rax, rsi); PrintOutRegisterInHex k0; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k1, rax, rsi); PrintOutRegisterInHex k1; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k2, rax, rsi); PrintOutRegisterInHex k2; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k3, rax, rsi); PrintOutRegisterInHex k3; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k4, rax, rsi); PrintOutRegisterInHex k4; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k5, rax, rsi); PrintOutRegisterInHex k5; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k6, rax, rsi); PrintOutRegisterInHex k6; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Inc rsi; SetMaskRegister(k7, rax, rsi); PrintOutRegisterInHex k7; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply Assemble, < SetZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutZF; ClearZF; PrintOutZF; SetZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutZF; SetZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutZF; ClearZF; PrintOutZF; ok Assemble =~ m(ZF=1.*ZF=0.*ZF=1.*ZF=1.*ZF=0)s; =head3 ClearZF() Clear the zero flag B SetZF; PrintOutZF; ClearZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutZF; SetZF; PrintOutZF; SetZF; PrintOutZF; ClearZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutZF; ok Assemble =~ m(ZF=1.*ZF=0.*ZF=1.*ZF=1.*ZF=0)s; =head2 Tracing Trace the execution of a program =head3 Trace() Add tracing code =head2 Tracking Track the use of registers so that we do not accidently use unset registers or write into registers that are already in use. =head3 Keep(@target) Mark registers as in use so that they cannot be updated until we explicitly free them. Complain if the register is already in use. Parameter Description 1 @target Registers to keep =head3 KeepSet($target) Confirm that the specified registers are in use Parameter Description 1 $target Registers to keep =head3 KeepPush(@target) Push the current status of the specified registers and then mark them as free Parameter Description 1 @target Registers to keep =head3 KeepPop(@target) Reset the status of the specified registers to the status quo ante the last push Parameter Description 1 @target Registers to keep =head3 KeepReturn(@target) Pop the specified register and mark it as in use to effect a subroutine return with this register. Parameter Description 1 @target Registers to return =head3 KeepFree(@target) Free registers so that they can be reused Parameter Description 1 @target Registers to free =head2 Mask Operations on mask registers =head3 LoadConstantIntoMaskRegister($reg, $value) Load a constant into a mask register Parameter Description 1 $reg Mask register to load 2 $value Constant to load B Mov r14, 0; Kmovq k0, r14; KeepFree r14; Ktestq k0, k0; IfZ {PrintOutStringNL "0 & 0 == 0"}; PrintOutZF; LoadConstantIntoMaskRegister k1, 1; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Ktestq k1, k1; IfNz {PrintOutStringNL "1 & 1 != 0"}; PrintOutZF; LoadConstantIntoMaskRegister k2, eval "0b".(('1'x4).('0'x4))x2; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex k0, k1, k2; Mov r15, 0x89abcdef; Mov r14, 0x01234567; Shl r14, 32; Or r15, r14; Push r15; Push r15; KeepFree r15; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; my $a = Vq('aaaa'); $a->pop; $a->push; $a->outNL; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; ok Assemble(debug => 0, eq => < Mov rax, 0; Test rax,rax; IfNz {PrintOutRegisterInHex rax; } sub {PrintOutRegisterInHex rbx; }; KeepFree rax; Mov rax, 1; Test rax,rax; IfNz {PrintOutRegisterInHex rcx; } sub {PrintOutRegisterInHex rdx; }; ok Assemble =~ m(rbx.*rcx)s; =head2 Then($body) Then body for an If statement Parameter Description 1 $body Then body =head2 Else($body) Else body for an If statement Parameter Description 1 $body Else body =head2 IfEq($then, $else) If equal execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfNe($then, $else) If not equal execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfNz($then, $else) If the zero is not set then execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfZ($then, $else) If the zero is set then execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfLt($then, $else) If less than execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfLe($then, $else) If less than or equal execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfGt($then, $else) If greater than execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 IfGe($then, $else) If greater than or equal execute the then body else the else body Parameter Description 1 $then Then - required 2 $else Else - optional =head2 Block($body) Execute a block of code one with the option of jumping out of the block or restarting the block via the supplied labels. Parameter Description 1 $body Body B Mov rax, 0; Block # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ {my ($start, $end) = @_; PrintOutRegisterInHex rax; Cmp rax, 3; IfGe {Jmp $end}; Inc rax; PrintOutRegisterInHex rax Jmp $start; }; ok Assemble(debug => 0, eq => < For # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ {my ($start, $end, $next) = @_; Cmp rax, 3; IfGe {Jmp $end}; PrintOutRegisterInHex rax; } rax, 16, 1; ok Assemble(debug => 0, eq => < the name of the subroutine so it can be reused rather than regenerated, comment=> a comment describing the sub Parameter Description 1 $body Body 2 %options Options. =head2 Subroutine($body, %options) Create a subroutine that can be called in assembler code Parameter Description 1 $body Body 2 %options Options. =head2 Nasm::X86::Sub::call($sub, @parameters) Call a sub passing it some parameters Parameter Description 1 $sub Subroutine descriptor 2 @parameters Parameter variables =head2 cr($body, @registers) Call a subroutine with a reordering of the registers. Parameter Description 1 $body Code to execute with reordered registers 2 @registers Registers to reorder =head2 Comment(@comment) Insert a comment into the assembly code Parameter Description 1 @comment Text of comment B Comment "Print a string from memory"; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $s = "Hello World"; Mov rax, Rs($s); Mov rdi, length $s; PrintOutMemory; ok Assemble =~ m(Hello World); =head2 DComment(@comment) Insert a comment into the data segment Parameter Description 1 @comment Text of comment =head2 RComment(@comment) Insert a comment into the read only data segment Parameter Description 1 @comment Text of comment =head1 Print Print =head2 PrintNL($channel) Print a new line to stdout or stderr Parameter Description 1 $channel Channel to write on =head2 PrintErrNL() Print a new line to stderr =head2 PrintOutNL() Print a new line to stderr B my $q = Rs('abababab'); Mov(rax, "[$q]"); PrintOutString "rax: "; PrintOutRaxInHex; PrintOutNL; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Xor rax, rax; PrintOutString "rax: "; PrintOutRaxInHex; PrintOutNL; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble =~ m(rax: 6261 6261 6261 6261.*rax: 0000 0000 0000 0000)s; =head2 PrintString($channel, @string) Print a constant string to the specified channel Parameter Description 1 $channel Channel 2 @string Strings =head2 PrintErrString(@string) Print a constant string to stderr. Parameter Description 1 @string String =head2 PrintOutString(@string) Print a constant string to stdout. Parameter Description 1 @string String =head2 PrintErrStringNL(@string) Print a constant string followed by a new line to stderr Parameter Description 1 @string Strings B PrintOutStringNL "Hello World"; PrintOutStringNL "Hello World"; PrintErrStringNL "Hello World"; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble(debug => 0, eq => < PrintOutStringNL "Hello World"; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutStringNL "Hello World"; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintErrStringNL "Hello World"; ok Assemble(debug => 0, eq => < my $q = Rs('abababab'); Mov(rax, "[$q]"); PrintOutString "rax: "; PrintOutRaxInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutNL; Xor rax, rax; PrintOutString "rax: "; PrintOutRaxInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutNL; ok Assemble =~ m(rax: 6261 6261 6261 6261.*rax: 0000 0000 0000 0000)s; =head2 PrintOutRaxInReverseInHex() Write the content of register rax to stderr in hexadecimal in little endian notation B Mov rax, 0x07654321; Shl rax, 32; Or rax, 0x07654321; PushR rax; PrintOutRaxInHex; PrintOutNL; PrintOutRaxInReverseInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutNL; KeepFree rax; Mov rax, rsp; Mov rdi, 8; PrintOutMemoryInHex; PrintOutNL; PopR rax; KeepFree rax, rdi; Mov rax, 4096; PushR rax; Mov rax, rsp; Mov rdi, 8; PrintOutMemoryInHex; PrintOutNL; PopR rax; is_deeply Assemble, < my $q = Rs(('a'..'p')x4); Mov r8,"[$q]"; PrintOutRegisterInHex r8; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble =~ m(r8: 6867 6665 6463 6261)s; =head2 PrintOutRegistersInHex() Print the general purpose registers in hex B my $q = Rs('abababab'); Mov(rax, 1); Mov(rbx, 2); Mov(rcx, 3); Mov(rdx, 4); Mov(r8, 5); Lea r9, "[rax+rbx]"; PrintOutRegistersInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $r = Assemble; ok $r =~ m( r8: 0000 0000 0000 0005.* r9: 0000 0000 0000 0003.*rax: 0000 0000 0000 0001)s; ok $r =~ m(rbx: 0000 0000 0000 0002.*rcx: 0000 0000 0000 0003.*rdx: 0000 0000 0000 0004)s; =head2 PrintErrZF() Print the zero flag without disturbing it on stderr =head2 PrintOutZF() Print the zero flag without disturbing it on stdout B SetZF; PrintOutZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ClearZF; PrintOutZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ SetZF; PrintOutZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ SetZF; PrintOutZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ClearZF; PrintOutZF; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble =~ m(ZF=1.*ZF=0.*ZF=1.*ZF=1.*ZF=0)s; =head1 Variables Variable definitions and operations =head2 Scopes Each variable is contained in a scope in an effort to detect references to out of scope variables =head3 Scope($name) Create and stack a new scope and continue with it as the current scope Parameter Description 1 $name Scope name B if (1) {my $start = Scope(start); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $s1 = Scope(s1); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $s2 = Scope(s2); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply $s2->depth, 2; is_deeply $s2->name, q(s2); ScopeEnd; my $t1 = Scope(t1); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t2 = Scope(t2); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply $t1->depth, 2; is_deeply $t1->name, q(t1); is_deeply $t2->depth, 3; is_deeply $t2->name, q(t2); ok $s1->currentlyVisible; ok !$s2->currentlyVisible; ok $s1->contains($t2); ok !$s2->contains($t2); ScopeEnd; is_deeply $s1->depth, 1; is_deeply $s1->name, q(s1); ScopeEnd; } =head3 ScopeEnd() End the current scope and continue with the containing parent scope B if (1) {my $start = Scope(start); my $s1 = Scope(s1); my $s2 = Scope(s2); is_deeply $s2->depth, 2; is_deeply $s2->name, q(s2); ScopeEnd; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $t1 = Scope(t1); my $t2 = Scope(t2); is_deeply $t1->depth, 2; is_deeply $t1->name, q(t1); is_deeply $t2->depth, 3; is_deeply $t2->name, q(t2); ok $s1->currentlyVisible; ok !$s2->currentlyVisible; ok $s1->contains($t2); ok !$s2->contains($t2); ScopeEnd; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply $s1->depth, 1; is_deeply $s1->name, q(s1); ScopeEnd; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ } =head3 Nasm::X86::Scope::contains($parent, $child) Check that the named parent scope contains the specified child scope. If no child scope is supplied we use the current scope to check that the parent scope is currently visible Parameter Description 1 $parent Parent scope 2 $child Child scope =head3 Nasm::X86::Scope::currentlyVisible($scope) Check that the named parent scope is currently visible Parameter Description 1 $scope Scope to check for visibility =head2 Definitions Variable definitions =head3 Variable($size, $name, $expr, %options) Create a new variable with the specified size and name initialized via an expression Parameter Description 1 $size Size as a power of 2 2 $name Name of variable 3 $expr Optional expression initializing variable 4 %options Options =head3 Vb($name, $expr, %options) Define a byte variable Parameter Description 1 $name Name of variable 2 $expr Initializing expression 3 %options Options =head3 Vw($name, $expr, %options) Define a word variable Parameter Description 1 $name Name of variable 2 $expr Initializing expression 3 %options Options =head3 Vd($name, $expr, %options) Define a double word variable Parameter Description 1 $name Name of variable 2 $expr Initializing expression 3 %options Options =head3 Vq($name, $expr, %options) Define a quad variable Parameter Description 1 $name Name of variable 2 $expr Initializing expression 3 %options Options =head3 Cq($name, $expr, %options) Define a quad constant Parameter Description 1 $name Name of variable 2 $expr Initializing expression 3 %options Options =head3 VxyzInit($var, @expr) Initialize an xyz register from general purpose registers Parameter Description 1 $var Variable 2 @expr Initializing general purpose registers or undef =head3 Vx($name, @expr) Define an xmm variable Parameter Description 1 $name Name of variable 2 @expr Initializing expression =head3 Vy($name, @expr) Define an ymm variable Parameter Description 1 $name Name of variable 2 @expr Initializing expression =head3 Vz($name, @expr) Define an zmm variable Parameter Description 1 $name Name of variable 2 @expr Initializing expression =head3 Vr($name, $size) Define a reference variable Parameter Description 1 $name Name of variable 2 $size Variable being referenced =head2 Operations Variable operations =head3 Nasm::X86::Variable::address($left, $offset) Get the address of a variable with an optional offset Parameter Description 1 $left Left variable 2 $offset Optional offset =head3 Nasm::X86::Variable::copy($left, $right) Copy one variable into another Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::clone($var) Clone a variable to create a new variable Parameter Description 1 $var Variable to clone =head3 Nasm::X86::Variable::copyAddress($left, $right) Copy a reference to a variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::equals($op, $left, $right) Equals operator Parameter Description 1 $op Operator 2 $left Left variable 3 $right Right variable =head3 Nasm::X86::Variable::assign($left, $op, $right) Assign to the left hand side the value of the right hand side Parameter Description 1 $left Left variable 2 $op Operator 3 $right Right variable =head3 Nasm::X86::Variable::plusAssign($left, $right) Implement plus and assign Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::minusAssign($left, $right) Implement minus and assign Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::arithmetic($op, $name, $left, $right) Return a variable containing the result of an arithmetic operation on the left hand and right hand side variables Parameter Description 1 $op Operator 2 $name Operator name 3 $left Left variable 4 $right Right variable =head3 Nasm::X86::Variable::add($left, $right) Add the right hand variable to the left hand variable and return the result as a new variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::sub($left, $right) Subtract the right hand variable from the left hand variable and return the result as a new variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::times($left, $right) Multiply the left hand variable by the right hand variable and return the result as a new variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::division($op, $left, $right) Return a variable containing the result or the remainder that occurs when the left hand side is divided by the right hand side Parameter Description 1 $op Operator 2 $left Left variable 3 $right Right variable =head3 Nasm::X86::Variable::divide($left, $right) Divide the left hand variable by the right hand variable and return the result as a new variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::mod($left, $right) Divide the left hand variable by the right hand variable and return the remainder as a new variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::boolean($sub, $op, $left, $right) Combine the left hand variable with the right hand variable via a boolean operator Parameter Description 1 $sub Operator 2 $op Operator name 3 $left Left variable 4 $right Right variable =head3 Nasm::X86::Variable::eq($left, $right) Check whether the left hand variable is equal to the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::ne($left, $right) Check whether the left hand variable is not equal to the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::ge($left, $right) Check whether the left hand variable is greater than or equal to the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::gt($left, $right) Check whether the left hand variable is greater than the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::le($left, $right) Check whether the left hand variable is less than or equal to the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head3 Nasm::X86::Variable::lt($left, $right) Check whether the left hand variable is less than the right hand variable Parameter Description 1 $left Left variable 2 $right Right variable =head2 Print variables Print the values of variables or the memory addressed by them =head3 Nasm::X86::Variable::dump($left, $channel, $newLine, $title1, $title2) Dump the value of a variable to the specified channel adding an optional title and new line if requested Parameter Description 1 $left Left variable 2 $channel Channel 3 $newLine New line required 4 $title1 Optional leading title 5 $title2 Optional trailing title B my $a = Vq(a, 3); $a->outNL; my $b = Vq(b, 2); $b->outNL; my $c = $a + $b; $c->outNL; my $d = $c - $a; $d->outNL; my $e = $d == $b; $e->outNL; my $f = $d != $b; $f->outNL; my $g = $a * $b; $g->outNL; my $h = $g / $b; $h->outNL; my $i = $a % $b; $i->outNL; If ($a == 3, sub{PrintOutStringNL "a == 3"}); ++$a; $a->outNL; --$a; $a->outNL; ok Assemble(debug => 0, eq => < my $a = Vq("a", 1); my $b = Vq("b", 2); my $c = $a->min($b); my $d = $a->max($b); $a->outNL; $b->outNL; $c->outNL; $d->outNL; is_deeply Assemble,< my $a = Vq("a", 1); my $b = Vq("b", 2); my $c = $a->min($b); my $d = $a->max($b); $a->outNL; $b->outNL; $c->outNL; $d->outNL; is_deeply Assemble,< my $start = Vq("Start", 7); my $length = Vq("Length", 3); $start->setMask($length, k7); PrintOutRegisterInHex k7; is_deeply Assemble, <setMask($o, k7); PrintOutRegisterInHex k7; $z->setMask($t, k6); PrintOutRegisterInHex k6; $z->setMask($o+$t, k5); PrintOutRegisterInHex k5; $o->setMask($o, k4); PrintOutRegisterInHex k4; $o->setMask($t, k3); PrintOutRegisterInHex k3; $o->setMask($o+$t, k2); PrintOutRegisterInHex k2; $t->setMask($o, k1); PrintOutRegisterInHex k1; $t->setMask($t, k0); PrintOutRegisterInHex k0; ok Assemble(debug => 0, eq => < my $s = Rb(0..128); my $source = Vq(Source, $s); if (1) # First block {my $offset = Vq(Offset, 7); my $length = Vq(Length, 3); $source->setZmm(0, $offset, $length); } if (1) # Second block {my $offset = Vq(Offset, 33); my $length = Vq(Length, 12); $source->setZmm(0, $offset, $length); } PrintOutRegisterInHex zmm0; is_deeply Assemble, <loadZmm(0); # Show variable in zmm0 $b ->loadZmm(1); # Show variable in zmm1 ($a + $b)->loadZmm(2); # Add bytes and show in zmm2 ($a - $b)->loadZmm(3); # Subtract bytes and show in zmm3 PrintOutRegisterInHex "zmm$_" for 0..3; is_deeply Assemble, < my $s = Rb(0..8); my $c = Vq("Content", "[$s]"); $c->putBIntoZmm(0, 4); $c->putWIntoZmm(0, 6); $c->putDIntoZmm(0, 10); $c->putQIntoZmm(0, 16); PrintOutRegisterInHex zmm0; getBFromZmm(0, 12)->outNL; getWFromZmm(0, 12)->outNL; getDFromZmm(0, 12)->outNL; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ getQFromZmm(0, 12)->outNL; is_deeply Assemble, < my $s = Rb(0..8); my $c = Vq("Content", "[$s]"); $c->putBIntoZmm(0, 4); $c->putWIntoZmm(0, 6); $c->putDIntoZmm(0, 10); $c->putQIntoZmm(0, 16); PrintOutRegisterInHex zmm0; getBFromZmm(0, 12)->outNL; getWFromZmm(0, 12)->outNL; getDFromZmm(0, 12)->outNL; getQFromZmm(0, 12)->outNL; is_deeply Assemble, < my $N = Vq(size, 2048); my $q = Rs('a'..'p'); AllocateMemory($N, my $address = Vq(address)); Vmovdqu8 xmm0, "[$q]"; $address->setReg(rax); Vmovdqu8 "[rax]", xmm0; Mov rdi, 16; PrintOutMemory; PrintOutNL; FreeMemory(address => $address, size=> $N); ok Assemble(eq => < Vq(limit,10)->for(sub {my ($i, $start, $next, $end) = @_; $i->outNL; }); is_deeply Assemble, < Mov rax, 0x11111111; Mov rbx, 0x22222222; PushR my @save = (rax, rbx); Mov rax, 0x33333333; PopR @save; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; is_deeply Assemble,< Mov r14, 0; Kmovq k0, r14; KeepFree r14; Ktestq k0, k0; IfZ {PrintOutStringNL "0 & 0 == 0"}; PrintOutZF; LoadConstantIntoMaskRegister k1, 1; Ktestq k1, k1; IfNz {PrintOutStringNL "1 & 1 != 0"}; PrintOutZF; LoadConstantIntoMaskRegister k2, eval "0b".(('1'x4).('0'x4))x2; PrintOutRegisterInHex k0, k1, k2; Mov r15, 0x89abcdef; Mov r14, 0x01234567; Shl r14, 32; Or r15, r14; Push r15; Push r15; KeepFree r15; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $a = Vq('aaaa'); $a->pop; $a->push; $a->outNL; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble(debug => 0, eq => < Fork; # Fork # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Test rax,rax; IfNz # Parent {Mov rbx, rax; WaitPid; PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; KeepFree rax; GetPid; # Pid of parent as seen in parent Mov rcx,rax; PrintOutRegisterInHex rcx; } sub # Child {Mov r8,rax; PrintOutRegisterInHex r8; KeepFree rax; GetPid; # Child pid as seen in child Mov r9,rax; PrintOutRegisterInHex r9; KeepFree rax; GetPPid; # Parent pid as seen in child Mov r10,rax; PrintOutRegisterInHex r10; }; my $r = Assemble; # r8: 0000 0000 0000 0000 #1 Return from fork as seen by child # r9: 0000 0000 0003 0C63 #2 Pid of child # r10: 0000 0000 0003 0C60 #3 Pid of parent from child # rax: 0000 0000 0003 0C63 #4 Return from fork as seen by parent # rbx: 0000 0000 0003 0C63 #5 Wait for child pid result # rcx: 0000 0000 0003 0C60 #6 Pid of parent if ($r =~ m(r8:( 0000){4}.*r9:(.*)\s{5,}r10:(.*)\s{5,}rax:(.*)\s{5,}rbx:(.*)\s{5,}rcx:(.*)\s{2,})s) {ok $2 eq $4; ok $2 eq $5; ok $3 eq $6; ok $2 gt $6; } =head3 GetPid() Get process identifier B Fork; # Fork Test rax,rax; IfNz # Parent {Mov rbx, rax; WaitPid; PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; KeepFree rax; GetPid; # Pid of parent as seen in parent # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rcx,rax; PrintOutRegisterInHex rcx; } sub # Child {Mov r8,rax; PrintOutRegisterInHex r8; KeepFree rax; GetPid; # Child pid as seen in child # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov r9,rax; PrintOutRegisterInHex r9; KeepFree rax; GetPPid; # Parent pid as seen in child Mov r10,rax; PrintOutRegisterInHex r10; }; my $r = Assemble; # r8: 0000 0000 0000 0000 #1 Return from fork as seen by child # r9: 0000 0000 0003 0C63 #2 Pid of child # r10: 0000 0000 0003 0C60 #3 Pid of parent from child # rax: 0000 0000 0003 0C63 #4 Return from fork as seen by parent # rbx: 0000 0000 0003 0C63 #5 Wait for child pid result # rcx: 0000 0000 0003 0C60 #6 Pid of parent if ($r =~ m(r8:( 0000){4}.*r9:(.*)\s{5,}r10:(.*)\s{5,}rax:(.*)\s{5,}rbx:(.*)\s{5,}rcx:(.*)\s{2,})s) {ok $2 eq $4; ok $2 eq $5; ok $3 eq $6; ok $2 gt $6; } =head3 GetPidInHex() Get process identifier in hex as 8 zero terminated bytes in rax B GetPidInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; ok Assemble =~ m(rax: 00); =head3 GetPPid() Get parent process identifier B Fork; # Fork Test rax,rax; IfNz # Parent {Mov rbx, rax; WaitPid; PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; KeepFree rax; GetPid; # Pid of parent as seen in parent Mov rcx,rax; PrintOutRegisterInHex rcx; } sub # Child {Mov r8,rax; PrintOutRegisterInHex r8; KeepFree rax; GetPid; # Child pid as seen in child Mov r9,rax; PrintOutRegisterInHex r9; KeepFree rax; GetPPid; # Parent pid as seen in child # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov r10,rax; PrintOutRegisterInHex r10; }; my $r = Assemble; # r8: 0000 0000 0000 0000 #1 Return from fork as seen by child # r9: 0000 0000 0003 0C63 #2 Pid of child # r10: 0000 0000 0003 0C60 #3 Pid of parent from child # rax: 0000 0000 0003 0C63 #4 Return from fork as seen by parent # rbx: 0000 0000 0003 0C63 #5 Wait for child pid result # rcx: 0000 0000 0003 0C60 #6 Pid of parent if ($r =~ m(r8:( 0000){4}.*r9:(.*)\s{5,}r10:(.*)\s{5,}rax:(.*)\s{5,}rbx:(.*)\s{5,}rcx:(.*)\s{2,})s) {ok $2 eq $4; ok $2 eq $5; ok $3 eq $6; ok $2 gt $6; } =head3 GetUid() Get userid of current process B GetUid; # Userid # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; my $r = Assemble; ok $r =~ m(rax:( 0000){3}); =head3 WaitPid() Wait for the pid in rax to complete B Fork; # Fork Test rax,rax; IfNz # Parent {Mov rbx, rax; WaitPid; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; KeepFree rax; GetPid; # Pid of parent as seen in parent Mov rcx,rax; PrintOutRegisterInHex rcx; } sub # Child {Mov r8,rax; PrintOutRegisterInHex r8; KeepFree rax; GetPid; # Child pid as seen in child Mov r9,rax; PrintOutRegisterInHex r9; KeepFree rax; GetPPid; # Parent pid as seen in child Mov r10,rax; PrintOutRegisterInHex r10; }; my $r = Assemble; # r8: 0000 0000 0000 0000 #1 Return from fork as seen by child # r9: 0000 0000 0003 0C63 #2 Pid of child # r10: 0000 0000 0003 0C60 #3 Pid of parent from child # rax: 0000 0000 0003 0C63 #4 Return from fork as seen by parent # rbx: 0000 0000 0003 0C63 #5 Wait for child pid result # rcx: 0000 0000 0003 0C60 #6 Pid of parent if ($r =~ m(r8:( 0000){4}.*r9:(.*)\s{5,}r10:(.*)\s{5,}rax:(.*)\s{5,}rbx:(.*)\s{5,}rcx:(.*)\s{2,})s) {ok $2 eq $4; ok $2 eq $5; ok $3 eq $6; ok $2 gt $6; } =head3 ReadTimeStampCounter() Read the time stamp counter and return the time in nanoseconds in rax B for(1..10) {ReadTimeStampCounter; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; } my @s = split / /, Assemble; my @S = sort @s; is_deeply \@s, \@S; =head2 Memory Allocate and print memory =head3 PrintMemoryInHex($channel) Dump memory from the address in rax for the length in rdi on the specified channel. As this method prints in blocks of 8 up to 7 bytes will be missing from the end unless the length is a multiple of 8 . Parameter Description 1 $channel Channel =head3 PrintErrMemoryInHex() Dump memory from the address in rax for the length in rdi on stderr =head3 PrintOutMemoryInHex() Dump memory from the address in rax for the length in rdi on stdout B Mov rax, 0x07654321; Shl rax, 32; Or rax, 0x07654321; PushR rax; PrintOutRaxInHex; PrintOutNL; PrintOutRaxInReverseInHex; PrintOutNL; KeepFree rax; Mov rax, rsp; Mov rdi, 8; PrintOutMemoryInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutNL; PopR rax; KeepFree rax, rdi; Mov rax, 4096; PushR rax; Mov rax, rsp; Mov rdi, 8; PrintOutMemoryInHex; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutNL; PopR rax; is_deeply Assemble, < my $N = 256; my $s = Rb 0..$N-1; AllocateMemory(Cq(size, $N), my $a = Vq(address)); CopyMemory(Vq(source, $s), Vq(size, $N), target => $a); AllocateMemory(Cq(size, $N), my $b = Vq(address)); CopyMemory(source => $a, target => $b, Cq(size, $N)); $b->setReg(rax); Mov rdi, $N; PrintOutMemoryInHexNL; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble(debug=>0, eq => < ReadFile(Vq(file, Rs($0)), (my $s = Vq(size)), my $a = Vq(address)); # Read file $a->setReg(rax); # Address of file in memory $s->setReg(rdi); # Length of file in memory PrintOutMemory; # Print contents of memory to stdout my $r = Assemble; # Assemble and execute ok stringMd5Sum($r) eq fileMd5Sum($0); # Output contains this file =head3 PrintErrMemory() Print the memory addressed by rax for a length of rdi on stderr =head3 PrintOutMemory() Print the memory addressed by rax for a length of rdi on stdout B Comment "Print a string from memory"; my $s = "Hello World"; Mov rax, Rs($s); Mov rdi, length $s; PrintOutMemory; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble =~ m(Hello World); =head3 PrintErrMemoryNL() Print the memory addressed by rax for a length of rdi followed by a new line on stderr =head3 PrintOutMemoryNL() Print the memory addressed by rax for a length of rdi followed by a new line on stdout =head3 AllocateMemory(@variables) Allocate the specified amount of memory via mmap and return its address Parameter Description 1 @variables Parameters B my $N = Vq(size, 2048); my $q = Rs('a'..'p'); AllocateMemory($N, my $address = Vq(address)); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Vmovdqu8 xmm0, "[$q]"; $address->setReg(rax); Vmovdqu8 "[rax]", xmm0; Mov rdi, 16; PrintOutMemory; PrintOutNL; FreeMemory(address => $address, size=> $N); ok Assemble(eq => <setReg(rax); $N->setReg(rdi); PrintOutMemoryInHexNL; FreeMemory($N, $A); ok Assemble(eq => < $a); AllocateMemory(Cq(size, $N), my $b = Vq(address)); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CopyMemory(source => $a, target => $b, Cq(size, $N)); $b->setReg(rax); Mov rdi, $N; PrintOutMemoryInHexNL; ok Assemble(debug=>0, eq => < my $N = Vq(size, 4096); # Size of the initial allocation which should be one or more pages AllocateMemory($N, my $A = Vq(address)); ClearMemory($N, $A); $A->setReg(rax); $N->setReg(rdi); PrintOutMemoryInHexNL; FreeMemory($N, $A); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble(eq => < my $N = Vq(size, 4096); # Size of the initial allocation which should be one or more pages AllocateMemory($N, my $A = Vq(address)); ClearMemory($N, $A); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ $A->setReg(rax); $N->setReg(rdi); PrintOutMemoryInHexNL; FreeMemory($N, $A); ok Assemble(eq => < my $s = Rb 0; Rb 1; Rw 2; Rd 3; Rq 4; my $t = Db 0; Db 1; Dw 2; Dd 3; Dq 4; Vmovdqu8 xmm0, "[$s]"; Vmovdqu8 xmm1, "[$t]"; PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; Sub rsp, 16; Mov rax, rsp; # Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi Mov rdi, 16; Mov rsi, $s; CopyMemory(Vq(source, rsi), Vq(target, rax), Vq(size, rdi)); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutMemoryInHex; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(xmm1: 0000 0000 0000 0004 0000 0003 0002 0100); ok $r =~ m(0001 0200 0300 00000400 0000 0000 0000); my $N = 256; my $s = Rb 0..$N-1; AllocateMemory(Cq(size, $N), my $a = Vq(address)); CopyMemory(Vq(source, $s), Vq(size, $N), target => $a); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ AllocateMemory(Cq(size, $N), my $b = Vq(address)); CopyMemory(source => $a, target => $b, Cq(size, $N)); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ $b->setReg(rax); Mov rdi, $N; PrintOutMemoryInHexNL; ok Assemble(debug=>0, eq => < Mov rax, Rs($0); # File to read OpenRead; # Open file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; CloseFile; # Close file PrintOutRegisterInHex rax; KeepFree rax, rdi; Mov rax, Rs(my $f = "zzzTemporaryFile.txt"); # File to write OpenWrite; # Open file CloseFile; # Close file is_deeply Assemble, < Mov rax, Rs($0); # File to read OpenRead; # Open file PrintOutRegisterInHex rax; CloseFile; # Close file PrintOutRegisterInHex rax; KeepFree rax, rdi; Mov rax, Rs(my $f = "zzzTemporaryFile.txt"); # File to write OpenWrite; # Open file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CloseFile; # Close file is_deeply Assemble, < Mov rax, Rs($0); # File to read OpenRead; # Open file PrintOutRegisterInHex rax; CloseFile; # Close file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; KeepFree rax, rdi; Mov rax, Rs(my $f = "zzzTemporaryFile.txt"); # File to write OpenWrite; # Open file CloseFile; # Close file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ is_deeply Assemble, < Mov rax, Rs($0); # File to stat StatSize; # Stat the file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex rax; my $r = Assemble =~ s( ) ()gsr; if ($r =~ m(rax:([0-9a-f]{16}))is) # Compare file size obtained with that from fileSize() {is_deeply $1, sprintf("%016X", fileSize($0)); } =head3 ReadFile(@variables) Read a file whose name is addressed by rax into memory. The address of the mapped memory and its length are returned in registers rax,rdi Parameter Description 1 @variables Variables B ReadFile(Vq(file, Rs($0)), (my $s = Vq(size)), my $a = Vq(address)); # Read file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ $a->setReg(rax); # Address of file in memory $s->setReg(rdi); # Length of file in memory PrintOutMemory; # Print contents of memory to stdout my $r = Assemble; # Assemble and execute ok stringMd5Sum($r) eq fileMd5Sum($0); # Output contains this file =head3 executeFileViaBash(@variables) Execute the file named in the byte string addressed by rax with bash Parameter Description 1 @variables Variables B my $s = CreateByteString; # Create a string $s->ql(<write (my $f = Vq('file', Rs("zzz.sh"))); # Write code to a file executeFileViaBash($f); # Execute the file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ unlinkFile ($f); # Delete the file my $u = qx(whoami); chomp($u); ok Assemble(emulator=>0) =~ m($u); # The Intel Software Development Emulator is way too slow on these operations. =head3 unlinkFile(@variables) Unlink the named file Parameter Description 1 @variables Variables B my $s = CreateByteString; # Create a string $s->ql(<write (my $f = Vq('file', Rs("zzz.sh"))); # Write code to a file executeFileViaBash($f); # Execute the file unlinkFile ($f); # Delete the file # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ my $u = qx(whoami); chomp($u); ok Assemble(emulator=>0) =~ m($u); # The Intel Software Development Emulator is way too slow on these operations. =head1 Hash functions Hash functions =head2 Hash() Hash a string addressed by rax with length held in rdi and return the hash code in r15 B Mov rax, "[rbp+24]"; Cstrlen; # Length of string to hash Mov rdi, r15; Hash(); # Hash string # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ PrintOutRegisterInHex r15; my $e = Assemble keep=>'hash'; # Assemble to the specified file name ok qx($e "") =~ m(r15: 0000 3F80 0000 3F80); # Test well known hashes ok qx($e "a") =~ m(r15: 0000 3F80 C000 45B2); if (0) # Hash various strings # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ {my %r; my %f; my $count = 0; my $N = RegisterSize zmm0; if (1) # Fixed blocks {for my $l(qw(a ab abc abcd), 'a a', 'a a') {for my $i(1..$N) {my $t = $l x $i; last if $N < length $t; my $s = substr($t.(' ' x $N), 0, $N); next if $f{$s}++; my $r = qx($e "$s"); say STDERR "$count $r"; if ($r =~ m(^.*r15:\s*(.*)$)m) {push $r{$1}->@*, $s; ++$count; } } } } if (1) # Variable blocks {for my $l(qw(a ab abc abcd), '', 'a a', 'a a') {for my $i(1..$N) {my $t = $l x $i; next if $f{$t}++; my $r = qx($e "$t"); say STDERR "$count $r"; if ($r =~ m(^.*r15:\s*(.*)$)m) {push $r{$1}->@*, $t; ++$count; } } } } for my $r(keys %r) {delete $r{$r} if $r{$r}->@* < 2; } say STDERR dump(\%r); say STDERR "Keys hashed: ", $count; confess "Duplicates : ", scalar keys(%r); } =head1 Unicode Convert utf8 to utf32 =head2 GetNextUtf8CharAsUtf32(@parameters) Get the next utf8 encoded character from the addressed memory and return it as a utf32 char Parameter Description 1 @parameters Parameters =head2 ConvertUtf8ToUtf32(@parameters) Convert a string of utf8 to an allocated block of utf32 and return its address and length. Parameter Description 1 @parameters Parameters B my @p = my ($out, $size, $fail) = (Vq(out), Vq(size), Vq('fail')); my $opens = Vq(opens); my $class = Vq(class); my $Chars = Rb(0x24, 0xc2, 0xa2, 0xc9, 0x91, 0xE2, 0x82, 0xAC, 0xF0, 0x90, 0x8D, 0x88); my $chars = Vq(chars, $Chars); GetNextUtf8CharAsUtf32 in=>$chars, @p; # Dollar UTF-8 Encoding: 0x24 UTF-32 Encoding: 0x00000024 $out->out('out1 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+1, @p; # Cents UTF-8 Encoding: 0xC2 0xA2 UTF-32 Encoding: 0x000000a2 $out->out('out2 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+3, @p; # Alpha UTF-8 Encoding: 0xC9 0x91 UTF-32 Encoding: 0x00000251 $out->out('out3 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+5, @p; # Euro UTF-8 Encoding: 0xE2 0x82 0xAC UTF-32 Encoding: 0x000020AC $out->out('out4 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+8, @p; # Gothic Letter Hwair UTF-8 Encoding 0xF0 0x90 0x8D 0x88 UTF-32 Encoding: 0x00010348 $out->out('out5 : '); $size->outNL(' size : '); my $statement = qq(๐–บ ๐‘Ž๐‘ ๐‘ ๐‘–๐‘”๐‘› ใ€ใ€๐–ป ๐ฉ๐ฅ๐ฎ๐ฌ ๐–ผใ€‘ใ€‘ AAAAAAAA); # A sample sentence to parse my $s = Cq(statement, Rs($statement)); my $l = Cq(size, length($statement)); AllocateMemory($l, my $address = Vq(address)); # Allocate enough memory for a copy of the string CopyMemory(source => $s, target => $address, $l); GetNextUtf8CharAsUtf32 in=>$address, @p; $out->out('outA : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+4, @p; $out->out('outB : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+5, @p; $out->out('outC : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+30, @p; $out->out('outD : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+35, @p; $out->out('outE : '); $size->outNL(' size : '); $address->printOutMemoryInHexNL($l); # Single character classifications Cq('newLine', 0x0A)->putBIntoZmm(0, 0); #r 0x0 - open bracket #r 0x1 - close bracket Cq('newLine', 0x02)->putBIntoZmm(0, 3); #r 0x2 - new line, #r 0x3 - new line acting as a semi-colon Cq('space', 0x20)->putBIntoZmm(0, 4); Cq('space', 0x05)->putBIntoZmm(0, 7); #r 0x5 - space my sub pu32($$) # Print some utf32 characters {my ($n, $m) = @_; # Variable: number of characters to print, variable: address of memory $n->for(sub {my ($index, $start, $next, $end) = @_; my $a = $m + $index * 4; $a->setReg(r15); KeepFree r15; Mov r15d, "[r15]"; KeepFree r15; PrintOutRegisterInHex r15; }); } if (1) # Classify a utf32 string {my $a = Dd(0x0001d5ba, 0x00000020, 0x0001d44e, 0x0000000a, 0x0001d5bb, 0x0001d429); my $t = Cq('test', $a); my $s = Cq('size', 6); ClassifyCharacters4 address=>$t, size=>$s; PrintOutStringNL "Convert some utf8 to utf32"; pu32($s, $t); } # circledLatinLetter : assign โ’ถโ’ทโ’ธโ’นโ’บโ’ปโ’ผโ’ฝโ’พโ’ฟโ“€โ“โ“‚โ“ƒโ“„โ“…โ“†โ“‡โ“ˆโ“‰โ“Šโ“‹โ“Œโ“โ“Žโ“โ“โ“‘โ“’โ““โ“”โ“•โ“–โ“—โ“˜โ“™โ“šโ“›โ“œโ“โ“žโ“Ÿโ“ โ“กโ“ขโ“ฃโ“คโ“ฅโ“ฆโ“งโ“จโ“ฉ # mathematicalBold : dyad lr 3 ๐€๐๐‚๐ƒ๐„๐…๐†๐‡๐ˆ๐‰๐Š๐‹๐Œ๐๐Ž๐๐๐‘๐’๐“๐”๐•๐–๐—๐˜๐™๐š๐›๐œ๐๐ž๐Ÿ๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐šจ๐šฉ๐šช๐šซ๐šฌ๐šญ๐šฎ๐šฏ๐šฐ๐šฑ๐šฒ๐šณ๐šด๐šต๐šถ๐šท๐šธ๐šบ๐šป๐šผ๐šฝ๐šพ๐šฟ๐›€๐›‚๐›ƒ๐›„๐›…๐›†๐›‡๐›ˆ๐›‰๐›Š๐›‹๐›Œ๐›๐›Ž๐›๐›๐›‘๐›’๐›”๐›•๐›–๐›—๐›˜๐›™๐›š๐ŸŠ๐Ÿ‹ # mathematicalBoldFraktur : ๐•ฌ๐•ญ๐•ฎ๐•ฏ๐•ฐ๐•ฑ๐•ฒ๐•ณ๐•ด๐•ต๐•ถ๐•ท๐•ธ๐•น๐•บ๐•ป๐•ผ๐•ฝ๐•พ๐•ฟ๐–€๐–๐–‚๐–ƒ๐–„๐–…๐–†๐–‡๐–ˆ๐–‰๐–Š๐–‹๐–Œ๐–๐–Ž๐–๐–๐–‘๐–’๐–“๐–”๐–•๐––๐–—๐–˜๐–™๐–š๐–›๐–œ๐–๐–ž๐–Ÿ # mathematicalBoldItalic : prefix ๐‘จ๐‘ฉ๐‘ช๐‘ซ๐‘ฌ๐‘ญ๐‘ฎ๐‘ฏ๐‘ฐ๐‘ฑ๐‘ฒ๐‘ณ๐‘ด๐‘ต๐‘ถ๐‘ท๐‘ธ๐‘น๐‘บ๐‘ป๐‘ผ๐‘ฝ๐‘พ๐‘ฟ๐’€๐’๐’‚๐’ƒ๐’„๐’…๐’†๐’‡๐’ˆ๐’‰๐’Š๐’‹๐’Œ๐’๐’Ž๐’๐’๐’‘๐’’๐’“๐’”๐’•๐’–๐’—๐’˜๐’™๐’š๐’›๐œœ๐œ๐œž๐œŸ๐œ ๐œก๐œข๐œฃ๐œค๐œฅ๐œฆ๐œง๐œจ๐œฉ๐œช๐œซ๐œฌ๐œฎ๐œฏ๐œฐ๐œฑ๐œฒ๐œณ๐œด๐œถ๐œท๐œธ๐œน๐œบ๐œป๐œผ๐œฝ๐œพ๐œฟ๐€๐๐‚๐ƒ๐„๐…๐†๐ˆ๐‰๐Š๐‹๐Œ๐๐Ž # mathematicalBoldScript : ๐“๐“‘๐“’๐““๐“”๐“•๐“–๐“—๐“˜๐“™๐“š๐“›๐“œ๐“๐“ž๐“Ÿ๐“ ๐“ก๐“ข๐“ฃ๐“ค๐“ฅ๐“ฆ๐“ง๐“จ๐“ฉ๐“ช๐“ซ๐“ฌ๐“ญ๐“ฎ๐“ฏ๐“ฐ๐“ฑ๐“ฒ๐“ณ๐“ด๐“ต๐“ถ๐“ท๐“ธ๐“น๐“บ๐“ป๐“ผ๐“ฝ๐“พ๐“ฟ๐”€๐”๐”‚๐”ƒ # mathematicalDouble-struck : ๐”ธ๐”น๐”ป๐”ผ๐”ฝ๐”พ๐•€๐•๐•‚๐•ƒ๐•„๐•†๐•Š๐•‹๐•Œ๐•๐•Ž๐•๐•๐•’๐•“๐•”๐••๐•–๐•—๐•˜๐•™๐•š๐•›๐•œ๐•๐•ž๐•Ÿ๐• ๐•ก๐•ข๐•ฃ๐•ค๐•ฅ๐•ฆ๐•ง๐•จ๐•ฉ๐•ช๐•ซ # mathematicalFraktur : ๐”„๐”…๐”‡๐”ˆ๐”‰๐”Š๐”๐”Ž๐”๐”๐”‘๐”’๐”“๐””๐”–๐”—๐”˜๐”™๐”š๐”›๐”œ๐”ž๐”Ÿ๐” ๐”ก๐”ข๐”ฃ๐”ค๐”ฅ๐”ฆ๐”ง๐”จ๐”ฉ๐”ช๐”ซ๐”ฌ๐”ญ๐”ฎ๐”ฏ๐”ฐ๐”ฑ๐”ฒ๐”ณ๐”ด๐”ต๐”ถ๐”ท # mathematicalItalic : ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐‘€๐‘๐‘‚๐‘ƒ๐‘„๐‘…๐‘†๐‘‡๐‘ˆ๐‘‰๐‘Š๐‘‹๐‘Œ๐‘๐‘Ž๐‘๐‘๐‘‘๐‘’๐‘“๐‘”๐‘–๐‘—๐‘˜๐‘™๐‘š๐‘›๐‘œ๐‘๐‘ž๐‘Ÿ๐‘ ๐‘ก๐‘ข๐‘ฃ๐‘ค๐‘ฅ๐‘ฆ๐‘ง๐›ข๐›ฃ๐›ค๐›ฅ๐›ฆ๐›ง๐›จ๐›ฉ๐›ช๐›ซ๐›ฌ๐›ญ๐›ฎ๐›ฏ๐›ฐ๐›ฑ๐›ฒ๐›ด๐›ต๐›ถ๐›ท๐›ธ๐›น๐›บ๐›ผ๐›ฝ๐›พ๐›ฟ๐œ€๐œ๐œ‚๐œƒ๐œ„๐œ…๐œ†๐œ‡๐œˆ๐œ‰๐œŠ๐œ‹๐œŒ๐œŽ๐œ๐œ๐œ‘๐œ’๐œ“๐œ” # mathematicalMonospace : ๐™ฐ๐™ฑ๐™ฒ๐™ณ๐™ด๐™ต๐™ถ๐™ท๐™ธ๐™น๐™บ๐™ป๐™ผ๐™ฝ๐™พ๐™ฟ๐š€๐š๐š‚๐šƒ๐š„๐š…๐š†๐š‡๐šˆ๐š‰๐šŠ๐š‹๐šŒ๐š๐šŽ๐š๐š๐š‘๐š’๐š“๐š”๐š•๐š–๐š—๐š˜๐š™๐šš๐š›๐šœ๐š๐šž๐šŸ๐š ๐šก๐šข๐šฃ # mathematicalSans-serif : variable ๐– ๐–ก๐–ข๐–ฃ๐–ค๐–ฅ๐–ฆ๐–ง๐–จ๐–ฉ๐–ช๐–ซ๐–ฌ๐–ญ๐–ฎ๐–ฏ๐–ฐ๐–ฑ๐–ฒ๐–ณ๐–ด๐–ต๐–ถ๐–ท๐–ธ๐–น๐–บ๐–ป๐–ผ๐–ฝ๐–พ๐–ฟ๐—€๐—๐—‚๐—ƒ๐—„๐—…๐—†๐—‡๐—ˆ๐—‰๐—Š๐—‹๐—Œ๐—๐—Ž๐—๐—๐—‘๐—’๐—“ # mathematicalSans-serifBold : ๐—”๐—•๐—–๐——๐—˜๐—™๐—š๐—›๐—œ๐—๐—ž๐—Ÿ๐— ๐—ก๐—ข๐—ฃ๐—ค๐—ฅ๐—ฆ๐—ง๐—จ๐—ฉ๐—ช๐—ซ๐—ฌ๐—ญ๐—ฎ๐—ฏ๐—ฐ๐—ฑ๐—ฒ๐—ณ๐—ด๐—ต๐—ถ๐—ท๐—ธ๐—น๐—บ๐—ป๐—ผ๐—ฝ๐—พ๐—ฟ๐˜€๐˜๐˜‚๐˜ƒ๐˜„๐˜…๐˜†๐˜‡๐–๐—๐˜๐™๐š๐›๐œ๐๐ž๐Ÿ๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐ž€๐ž‚๐žƒ๐ž„๐ž…๐ž†๐ž‡๐žˆ # mathematicalSans-serifBoldItalic : postfix ๐˜ผ๐˜ฝ๐˜พ๐˜ฟ๐™€๐™๐™‚๐™ƒ๐™„๐™…๐™†๐™‡๐™ˆ๐™‰๐™Š๐™‹๐™Œ๐™๐™Ž๐™๐™๐™‘๐™’๐™“๐™”๐™•๐™–๐™—๐™˜๐™™๐™š๐™›๐™œ๐™๐™ž๐™Ÿ๐™ ๐™ก๐™ข๐™ฃ๐™ค๐™ฅ๐™ฆ๐™ง๐™จ๐™ฉ๐™ช๐™ซ๐™ฌ๐™ญ๐™ฎ๐™ฏ๐ž๐ž‘๐ž’๐ž“๐ž”๐ž•๐ž–๐ž—๐ž˜๐ž™๐žš๐ž›๐žœ๐ž๐žž๐žŸ๐ž ๐žข๐žฃ๐žค๐žฅ๐žฆ๐žง๐žจ๐žช๐žซ๐žฌ๐žญ๐žฎ๐žฏ๐žฐ๐žฑ๐žฒ๐žณ๐žด๐žต๐žถ๐žท๐žธ๐žน๐žบ๐žผ๐žฝ๐žพ๐žฟ๐Ÿ€๐Ÿ๐Ÿ‚ # mathematicalSans-serifItalic : ๐˜ˆ๐˜‰๐˜Š๐˜‹๐˜Œ๐˜๐˜Ž๐˜๐˜๐˜‘๐˜’๐˜“๐˜”๐˜•๐˜–๐˜—๐˜˜๐˜™๐˜š๐˜›๐˜œ๐˜๐˜ž๐˜Ÿ๐˜ ๐˜ก๐˜ข๐˜ฃ๐˜ค๐˜ฅ๐˜ฆ๐˜ง๐˜จ๐˜ฉ๐˜ช๐˜ซ๐˜ฌ๐˜ญ๐˜ฎ๐˜ฏ๐˜ฐ๐˜ฑ๐˜ฒ๐˜ณ๐˜ด๐˜ต๐˜ถ๐˜ท๐˜ธ๐˜น๐˜บ๐˜ป # mathematicalScript : ๐’œ๐’ž๐’Ÿ๐’ข๐’ฅ๐’ฆ๐’ฉ๐’ช๐’ซ๐’ฌ๐’ฎ๐’ฏ๐’ฐ๐’ฑ๐’ฒ๐’ณ๐’ด๐’ต๐’ถ๐’ท๐’ธ๐’น๐’ป๐’ฝ๐’พ๐’ฟ๐“€๐“๐“‚๐“ƒ๐“…๐“†๐“‡๐“ˆ๐“‰๐“Š๐“‹๐“Œ๐“๐“Ž๐“ # negativeCircledLatinLetter : ๐Ÿ…๐Ÿ…‘๐Ÿ…’๐Ÿ…“๐Ÿ…”๐Ÿ…•๐Ÿ…–๐Ÿ…—๐Ÿ…˜๐Ÿ…™๐Ÿ…š๐Ÿ…›๐Ÿ…œ๐Ÿ…๐Ÿ…ž๐Ÿ…Ÿ๐Ÿ… ๐Ÿ…ก๐Ÿ…ข๐Ÿ…ฃ๐Ÿ…ค๐Ÿ…ฅ๐Ÿ…ฆ๐Ÿ…ง๐Ÿ…จ๐Ÿ…ฉ # negativeSquaredLatinLetter : ๐Ÿ…ฐ๐Ÿ…ฑ๐Ÿ…ฒ๐Ÿ…ณ๐Ÿ…ด๐Ÿ…ต๐Ÿ…ถ๐Ÿ…ท๐Ÿ…ธ๐Ÿ…น๐Ÿ…บ๐Ÿ…ป๐Ÿ…ผ๐Ÿ…ฝ๐Ÿ…พ๐Ÿ…ฟ๐Ÿ†€๐Ÿ†๐Ÿ†‚๐Ÿ†ƒ๐Ÿ†„๐Ÿ†…๐Ÿ††๐Ÿ†‡๐Ÿ†ˆ๐Ÿ†‰ # squaredLatinLetter : ๐Ÿ„ฐ๐Ÿ„ฑ๐Ÿ„ฒ๐Ÿ„ณ๐Ÿ„ด๐Ÿ„ต๐Ÿ„ถ๐Ÿ„ท๐Ÿ„ธ๐Ÿ„น๐Ÿ„บ๐Ÿ„ป๐Ÿ„ผ๐Ÿ„ฝ๐Ÿ„พ๐Ÿ„ฟ๐Ÿ…€๐Ÿ…๐Ÿ…‚๐Ÿ…ƒ๐Ÿ…„๐Ÿ……๐Ÿ…†๐Ÿ…‡๐Ÿ…ˆ๐Ÿ…‰๐Ÿ†ฅ # semiColon : semicolon โŸข # Delete following code when the following test is completed if (0) # Convert utf8 test string to utf32 {my @p = my ($u32, $size32, $count) = (Vq(u32), Vq(size32), Vq(count)); ClassifyCharacters4 address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - special characters"; pu32($count, $u32); Cq('variable', 0x0) ->putDIntoZmm(0, 0); # Range classifications Cq('variable', 0x06) ->putBIntoZmm(0, 3); #r 0x6 - ascii Cq('variable', 0x01D5A0)->putDIntoZmm(0, 4); Cq('variable', 0x07) ->putBIntoZmm(0, 7); #r 0x7 - variable Cq('variable', 0x01D434)->putDIntoZmm(0, 8); Cq('variable', 0x08) ->putBIntoZmm(0, 11); #r 0x8 - assign Cq('variable', 0x01D400)->putDIntoZmm(0, 12); Cq('variable', 0x09) ->putBIntoZmm(0, 15); #r 0x9 - Cq('variable', 0x7f) ->putDIntoZmm(1, 0); Cq('variable', 0x06) ->putBIntoZmm(1, 3); Cq('variable', 0x01D5D3)->putDIntoZmm(1, 4); Cq('variable', 0x07) ->putBIntoZmm(1, 7); Cq('variable', 0x01D467)->putDIntoZmm(1, 8); Cq('variable', 0x08) ->putBIntoZmm(1, 11); Cq('variable', 0x01D433)->putDIntoZmm(1, 12); Cq('variable', 0x09) ->putBIntoZmm(1, 15); ClassifyInRange address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - ranges"; pu32($count, $u32); my $bl = Rd(0x10002045, 0x12002329, 0x1400276c, 0x16002770, 0x1c0027e6, 0x24002983, 0x26002987, 0x380029fc, 0x3a003008, 0x3e003010, 0x40003014, 0x4800ff3b, 0x4900ff3d, 0x4a00ff5b, 0x4b00ff5d, 0); my $bh = Rd(0x11002046, 0x1300232a, 0x1500276d, 0x1b002775, 0x230027ed, 0x25002984, 0x37002998, 0x390029fd, 0x3d00300b, 0x3f003011, 0x4700301b, 0x4800ff3b, 0x4900ff3d, 0x4a00ff5b, 0x4b00ff5d, 0); Vmovdqu8 zmm0, "[$bl]"; Vmovdqu8 zmm1, "[$bh]"; ClassifyWithInRange address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - brackets"; pu32($count, $u32); MatchBrackets address=>$u32, size=>$count, $opens, $fail; PrintOutStringNL "Convert test statement - bracket matching"; pu32($count, $u32); } $address->clearMemory($l); $address->printOutMemoryInHexNL($l); ok Assemble(debug => 0, eq => < my $s = Rb(3, 0x01, 0x02, 0x03); my $t = Rb(7, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a); LoadShortStringFromMemoryToZmm 0, $s; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ LoadShortStringFromMemoryToZmm 1, $t; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ConcatenateShortStrings(0, 1); PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 000A 0908 0706 0504 0302 010A); ok $r =~ m(xmm1: 0000 0000 0000 0000 0A09 0807 0605 0407); =head2 GetLengthOfShortString($reg, $zmm) Get the length of the short string held in the numbered zmm register into the specified register Parameter Description 1 $reg Register to hold length 2 $zmm Number of zmm register containing string =head2 SetLengthOfShortString($zmm, $reg) Set the length of the short string held in the numbered zmm register into the specified register Parameter Description 1 $zmm Number of zmm register containing string 2 $reg Register to hold length =head2 ConcatenateShortStrings($left, $right) Concatenate the numbered source zmm containing a short string with the short string in the numbered target zmm. Parameter Description 1 $left Target zmm 2 $right Source zmm =head1 Byte Strings Operations on Byte Strings =head2 StringLength(@parameters) Length of a zero terminated string Parameter Description 1 @parameters Parameters B StringLength(Vq(string, Rs("abcd")))->outNL; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Assemble(debug => 0, eq => <1 adds a free chain. B my $a = CreateByteString; # Create a string # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ $a->q('aa'); $a->out; PrintOutNL; is_deeply Assemble, <q('aa'); $b->q('bb'); $a->out; PrintOutNL; $b->out; PrintOutNL; is_deeply Assemble, <q('aa'); $a->q('AA'); $a->out; PrintOutNL; is_deeply Assemble, <q('aa'); $b->q('bb'); $a->q('AA'); $b->q('BB'); $a->q('aa'); $b->q('bb'); $a->out; $b->out; PrintOutNL; is_deeply Assemble, <q('ab'); my $b = CreateByteString; # Create target byte string # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ $b->append(source=>$a->bs); $b->append(source=>$a->bs); $a->append(source=>$b->bs); $b->append(source=>$a->bs); $a->append(source=>$b->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $a->out; PrintOutNL; # Print byte string $b->out; PrintOutNL; # Print byte string $a->length(my $sa = Vq(size)); $sa->outNL; $b->length(my $sb = Vq(size)); $sb->outNL; $a->clear; $a->length(my $sA = Vq(size)); $sA->outNL; $b->length(my $sB = Vq(size)); $sB->outNL; is_deeply Assemble, < my $format = Rd(map{4*$_+24} 0..64); my $b = CreateByteString; my $a = $b->allocBlock; Vmovdqu8 zmm31, "[$format]"; $b->putBlock($b->bs, $a, 31); my $r = $b->chain($b->bs, Vq(start, 0x18), 4); $r->outNL("chain1: "); my $s = $b->chain($b->bs, $r, 4); $s->outNL("chain2: "); my $t = $b->chain($b->bs, $s, 4); $t->outNL("chain3: "); my $A = $b->chain($b->bs, Vq(start, 0x18), 4, 4, 4); $A->outNL("chain4: "); # Get a long chain $b->putChain($b->bs, Vq(start, 0x18), Vq(end, 0xff), 4, 4, 4); # Put at the end of a long chain $b->dump; my $sub = Subroutine {my ($p) = @_; # Parameters If ($$p{c} == -1, sub {PrintOutStringNL "C is minus one"}, sub {PrintOutStringNL "C is NOT minus one"}, ); If ($$p{d} == -1, sub {PrintOutStringNL "D is minus one"}, sub {PrintOutStringNL "D is NOT minus one"}, ); my $C = $$p{c}->clone; $C->outNL; $$p{e} += 1; $$p{e}->outNL('E: '); $$p{f}->outNL('F1: '); $$p{f}++; $$p{f}->outNL('F2: '); } name=> 'aaa', in => {c => 3}, io => {d => 3, e => 3, f => 3}; my $c = Cq(c, -1); my $d = Cq(d, -1); my $e = Vq(e, 1); my $f = Vq(f, 2); $sub->call($c, $d, $e, $f); $f->outNL('F3: '); ok Assemble(debug => 0, eq => < my $a = CreateByteString; $a->dump; my $b1 = $a->allocBlock; $a->dump; my $b2 = $a->allocBlock; $a->dump; $a->freeBlock($b2); $a->dump; $a->freeBlock($b1); $a->dump; ok Assemble(debug => 0, eq => < my $a = CreateByteString; $a->dump; my $b1 = $a->allocBlock; $a->dump; my $b2 = $a->allocBlock; $a->dump; $a->freeBlock($b2); $a->dump; $a->freeBlock($b1); $a->dump; ok Assemble(debug => 0, eq => < Mov r14, 0; Kmovq k0, r14; KeepFree r14; Ktestq k0, k0; IfZ {PrintOutStringNL "0 & 0 == 0"}; PrintOutZF; LoadConstantIntoMaskRegister k1, 1; Ktestq k1, k1; IfNz {PrintOutStringNL "1 & 1 != 0"}; PrintOutZF; LoadConstantIntoMaskRegister k2, eval "0b".(('1'x4).('0'x4))x2; PrintOutRegisterInHex k0, k1, k2; Mov r15, 0x89abcdef; Mov r14, 0x01234567; Shl r14, 32; Or r15, r14; Push r15; Push r15; KeepFree r15; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; my $a = Vq('aaaa'); $a->pop; $a->push; $a->outNL; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; ok Assemble(debug => 0, eq => < my $format = Rs "Hello %s "; my $data = Rs "World"; Extern qw(printf exit malloc strcpy); Link 'c'; CallC 'malloc', length($format)+1; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov r15, rax; CallC 'strcpy', r15, $format; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CallC 'printf', r15, $data; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CallC 'exit', 0; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ ok Assemble(eq => < my $format = Rs "Hello %s "; my $data = Rs "World"; Extern qw(printf exit malloc strcpy); Link 'c'; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CallC 'malloc', length($format)+1; Mov r15, rax; CallC 'strcpy', r15, $format; CallC 'printf', r15, $data; CallC 'exit', 0; ok Assemble(eq => < my $format = Rs "Hello %s "; my $data = Rs "World"; Extern qw(printf exit malloc strcpy); Link 'c'; # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ CallC 'malloc', length($format)+1; Mov r15, rax; CallC 'strcpy', r15, $format; CallC 'printf', r15, $data; CallC 'exit', 0; ok Assemble(eq => < PrintOutStringNL "Hello World"; PrintOutStringNL "Hello World"; PrintErrStringNL "Hello World"; ok Assemble(debug => 0, eq => < Mov rax, 0x11111111; Mov rbx, 0x22222222; PushR my @save = (rax, rbx); # ๐—˜๐˜…๐—ฎ๐—บ๐—ฝ๐—น๐—ฒ Mov rax, 0x33333333; PopR @save; PrintOutRegisterInHex rax; PrintOutRegisterInHex rbx; is_deeply Assemble,< my $Sk = Rd(17..28, 0, 0, 12, 0xFF); my $Sd = Rd(17..28, 0, 0, 0xDD, 0xEE); my $Sn = Rd(1..13, 0, 0, 0xCC); my $sk = Rd(1..14, 14, 0xA1); my $sd = Rd(1..14, 0xCC, 0xA2); my $sn = Rd(1..15, 0xA3); my $rk = Rd((0)x14, 14, 0xB1); my $rd = Rd((0)x14, 0xCC, 0xB2); my $rn = Rd((0)x15, 0xB3); my $b = CreateByteString; my $t = $b->CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$Sk]"; Vmovdqu8 zmm30, "[$Sd]"; Vmovdqu8 zmm29, "[$Sn]"; Vmovdqu8 zmm28, "[$sk]"; Vmovdqu8 zmm27, "[$sd]"; Vmovdqu8 zmm26, "[$sn]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullLeftNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => < my $tk = Rd(1..12, 0, 0, 12, 0xC1); my $td = Rd(1..12, 0, 0, 0, 0xC2); my $tn = Rd(1, 0xBB, 3..13, 0, 0, 0xCC); my $lk = Rd(17..30, 14, 0xA1); my $ld = Rd(17..30, 0xCC, 0xA2); my $ln = Rd(17..31, 0xAA); my $rk = Rd(17..30, 14, 0xB1); my $rd = Rd(17..30, 0xCC, 0xB2); my $rn = Rd(17..31, 0xBB); my $b = CreateByteString; my $t = $b->CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$tk]"; Vmovdqu8 zmm30, "[$td]"; Vmovdqu8 zmm29, "[$tn]"; Vmovdqu8 zmm28, "[$lk]"; Vmovdqu8 zmm27, "[$ld]"; Vmovdqu8 zmm26, "[$ln]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullRightNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => < - Create a structure consisting of 8 byte fields 2 L - Create a local data descriptor consisting of the specified number of 8 byte local variables and return an array: (local data descriptor, variable definitions. 3 L - Allocate the specified amount of memory via mmap and return its address 4 L - Assemble the generated code 5 L - Execute a block of code one with the option of jumping out of the block or restarting the block via the supplied labels. 6 L - Call a C subroutine 7 L - Classify the utf32 characters in a block of memory of specified length using the classification held in zmm0: zmm0 should be formatted in double words with each word having the classification in the highest 8 bits and the utf32 character so classified in the lower 21 bits. 8 L - Character classification: classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with each word in zmm1 having the classification in the highest 8 bits and with zmm0 and zmm1 having the utf32 character at the start (zmm0) and end (zmm1) of each range in the lower 21 bits. 9 L - Implementation of ClassifyInRange and ClassifyWithinRange 10 L - Bracket classification: Classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with the classification range in the highest 8 bits of zmm0 and zmm1 and the utf32 character at the start (zmm0) and end (zmm1) of each range in the lower 21 bits. 11 L - Alphabetic classification: classify the utf32 characters in a block of memory of specified length using a range specification held in zmm0, zmm1 formatted in double words with the classification code in the high byte of zmm1 and the offset of the first element in the range in the high byte of zmm0. 12 L - Clear memory - the address of the memory is in rax, the length in rdi 13 L - Clear registers by setting them to zero 14 L - Clear the zero flag 15 L - Close the file whose descriptor is in rax 16 L - Insert a comment into the assembly code 17 L - Concatenate the numbered source zmm containing a short string with the short string in the numbered target zmm. 18 L - Convert a string of utf8 to an allocated block of utf32 and return its address and length. 19 L - Copy memory, the target is addressed by rax, the length is in rdi, the source is addressed by rsi 20 L - Define a quad constant 21 L - Call a subroutine with a reordering of the registers. 22 L - Create an relocatable string of bytes in an arena and returns its address in rax. 23 L - Length of the C style string addressed by rax returning the length in r15 24 L - Layout bytes in the data segment and return their label 25 L - Layout data 26 L - Insert a comment into the data segment 27 L - Layout double words in the data segment and return their label 28 L - Layout quad words in the data segment and return their label 29 L - Layout bytes in memory and return their label 30 L - Layout words in the data segment and return their label 31 L - Else body for an If statement 32 L - Execute the file named in the byte string addressed by rax with bash 33 L - Exit with the specified return code or zero if no return code supplied. 34 L - Name external references 35 L - 32 bit float 36 L - 64 bit float 37 L - For - iterate the body as long as register is less than limit incrementing by increment each time 38 L - Iterate for ever 39 L - For - iterate the full body as long as register plus increment is less than than limit incrementing by increment each time then increment the last body for the last non full block. 40 L - Fork 41 L - Free memory 42 L - Get the byte from the numbered xmm register and return it in a variable 43 L - Get the byte from the numbered zmm register and return it in a variable 44 L - Get the numbered byte|word|double word|quad word from the numbered zmm register and return it in a variable 45 L - Get the double word from the numbered xmm register and return it in a variable 46 L - Get the double word from the numbered zmm register and return it in a variable 47 L - Get the length of the short string held in the numbered zmm register into the specified register 48 L - Get the next utf8 encoded character from the addressed memory and return it as a utf32 char 49 L - Get process identifier 50 L - Get process identifier in hex as 8 zero terminated bytes in rax 51 L - Get parent process identifier 52 L - Get the quad word from the numbered xmm register and return it in a variable 53 L - Get the quad word from the numbered zmm register and return it in a variable 54 L - Get userid of current process 55 L - Get the word from the numbered xmm register and return it in a variable 56 L - Get the word from the numbered zmm register and return it in a variable 57 L - Hash a string addressed by rax with length held in rdi and return the hash code in r15 58 L - Create/address a hex translate table and return its label 59 L - If 60 L - If equal execute the then body else the else body 61 L - If greater than or equal execute the then body else the else body 62 L - If greater than execute the then body else the else body 63 L - If less than or equal execute the then body else the else body 64 L - If less than execute the then body else the else body 65 L - If not equal execute the then body else the else body 66 L - If the zero is not set then execute the then body else the else body 67 L - If the zero is set then execute the then body else the else body 68 L - Mark registers as in use so that they cannot be updated until we explicitly free them. 69 L - Free registers so that they can be reused 70 L - Reset the status of the specified registers to the status quo ante the last push 71 L - Push the current status of the specified registers and then mark them as free 72 L - Pop the specified register and mark it as in use to effect a subroutine return with this register. 73 L - Confirm that the specified registers are in use 74 L - Create a unique label 75 L - Libraries to link with 76 L - Load a constant into a mask register 77 L - Load the short string addressed by rax into the zmm register with the specified number 78 L - Load the short string addressed by rax into the zmm register with the specified number 79 L - Map local data 80 L - Locate the Intel Software Development Emulator 81 L - Create a sub with optional parameters name=> the name of the subroutine so it can be reused rather than regenerated, comment=> a comment describing the sub 82 L - Write the specified byte into locations in the target mask that correspond to the locations in the source that contain the specified byte. 83 L - Write the specified byte into locations in the target mask that correspond to the locations in the source that contain 4 bytes in the specified range. 84 L - Replace the low three bytes of a utf32 bracket character with 24 bits of offset to the matching opening or closing bracket. 85 L - Address of a block string 86 L - Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable 87 L - Dump a block array 88 L - Get an element from the array 89 L - Pop an element from an array 90 L - Push an element onto the array 91 L - Put an element into an array as long as it is with in its limits established by pushing. 92 L - Address of the byte string containing a block multi way tree 93 L - Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable 94 L - Allocate a keys/data/node block and place it in the numbered zmm registers 95 L - Call the specified body with each (key, data) from the specified tree in order 96 L - Return the depth of a node within a tree. 97 L - Find a key in a tree and return its associated data 98 L - Find a key in a tree which is known to contain at least one key splitting full nodes along the path to the key. 99 L - Load the keys and data blocks for a node 100 L - Load the keys, data and child nodes for a node 101 L - Get the length of the keys block in the numbered zmm and return it as a variable 102 L - Return the value of the loop field as a variable 103 L - Load the child nodes for a node 104 L - Get the up offset from the data block in the numbered zmm and return it as a variable 105 L - Insert a (key, data) pair into the tree 106 L - Iterate through a multi way tree 107 L - Next element in the tree 108 L - Return the left most node 109 L - Return the left most or right most node 110 L - Load the the node block into the numbered zmm corresponding to the data block held in the numbered zmm. 111 L - Save the key and data blocks for a node 112 L - Save the keys, data and child nodes for a node 113 L - Get the length of the block in the numbered zmm from the specified variable 114 L - Set the value of the loop field from a variable 115 L - Put the offset of the parent keys block expressed as a variable into the numbered zmm 116 L - Reparent the children of a node held in registers. 117 L - Return the right most node 118 L - Split a full left node block held in 28. 119 L - Split a full right node block held in 25. 120 L - Split a full root block held in 31. 121 L - Split a node given its offset in a byte string retaining the key being inserted in the node split while putting the remainder to the left or right. 122 L - Address of a block string 123 L - Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable 124 L - Append the specified content in memory to the specified block string 125 L - Clear the block by freeing all but the first block 126 L - Concatenate two block strings by appending a copy of the source to the target block string. 127 L - Delete a character in a block string 128 L - Dump a block string to sysout 129 L - Get the block with the specified offset in the specified block string and return it in the numbered zmm 130 L - Get the block length of the numbered zmm and return it in a variable 131 L - Get a character from a block string 132 L - Get the offsets of the next and previous blocks as variables from the specified zmm 133 L - Insert a character into a block string 134 L - Find the length of a block string 135 L - Write the numbered zmm to the block at the specified offset in the specified byte string 136 L - Save next and prev offsets into a zmm representing a block 137 L - Set the block length of the numbered zmm to the specified length 138 L - Allocate the amount of space indicated in rdi in the byte string addressed by rax and return the offset of the allocation in the arena in rdi 139 L - Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable 140 L - Allocate a block to hold a zmm register in the specified byte string and return the offset of the block in a variable 141 L - Append one byte string to another 142 L - Size of a block 143 L - Return a variable with the end point of a chain of double words in the byte string starting at the specified variable. 144 L - Append a character expressed as a decimal number to the byte string addressed by rax 145 L - Clear the byte string addressed by rax 146 L - Create a block array in a byte string 147 L - Create a block multi way tree in a byte string 148 L - Create a string from a doubly link linked list of 64 byte blocks linked via 4 byte offsets in the byte string addressed by rax and return its descriptor 149 L - Dump details of a byte string 150 L - Create and load a variable with the first free block on the free block chain or zero if no such block in the given byte string 151 L - Free a block in a byte string by placing it on the free chain 152 L - Get the block with the specified offset in the specified block string and return it in the numbered zmm 153 L - Get the length of a byte string 154 L - Append the content with length rdi addressed by rsi to the byte string addressed by rax 155 L - Make a byte string read only 156 L - Make a byte string writable 157 L - Append a new line to the byte string addressed by rax 158 L - Print the specified byte string addressed by rax on sysout 159 L - Write the numbered zmm to the block at the specified offset in the specified byte string 160 L - Write the double word in the specified variable to the double word location at the the specified offset in the specified byte string. 161 L - Append a constant string to the byte string 162 L - Append a quoted string containing new line characters to the byte string addressed by rax 163 L - Read the named file (terminated with a zero byte) and place it into the named byte string. 164 L - Set the first free block field from a variable 165 L - Make sure that the byte string addressed by rax has enough space to accommodate content of length rdi 166 L - Write the content in a byte string addressed by rax to a temporary file and replace the byte string content with the name of the temporary file 167 L - Append a trailing zero to the byte string addressed by rax 168 L - Add some 8 byte local variables and return an array of variable definitions 169 L - Free a local data area on the stack 170 L - Start a local data area on the stack 171 L - Add a local variable 172 L - Address a local variable on the stack 173 L - Check that the named parent scope contains the specified child scope. 174 L - Check that the named parent scope is currently visible 175 L - Add a field of the specified length with an optional comment 176 L - Address a field in a structure by either the default register or the named register 177 L - Call a sub passing it some parameters 178 L - Add the right hand variable to the left hand variable and return the result as a new variable 179 L - Get the address of a variable with an optional offset 180 L - Allocate the specified amount of memory via mmap and return its address 181 L - And two variables 182 L - Return a variable containing the result of an arithmetic operation on the left hand and right hand side variables 183 L - Assign to the left hand side the value of the right hand side 184 L - Combine the left hand variable with the right hand variable via a boolean operator 185 L - Clear a bit in the specified mask register retaining the other bits 186 L - Clear the memory described in this variable 187 L - Clone a variable to create a new variable 188 L - Copy one variable into another 189 L - Copy a reference to a variable 190 L - Copy from one block of memory to another 191 L - Dump the value of a variable on stdout with an indication of where the dump came from 192 L - Decrement a variable 193 L - Divide the left hand variable by the right hand variable and return the result as a new variable 194 L - Return a variable containing the result or the remainder that occurs when the left hand side is divided by the right hand side 195 L - Dump the value of a variable to the specified channel adding an optional title and new line if requested 196 L - Check whether the left hand variable is equal to the right hand variable 197 L - Equals operator 198 L - Dump the value of a variable on stderr 199 L - Dump the value of a variable on stderr and append a new line 200 L - Iterate the body limit times. 201 L - Free the memory addressed by this variable for the specified length 202 L - Check whether the left hand variable is greater than or equal to the right hand variable 203 L - Get the byte from the numbered zmm register and put it in a variable 204 L - Load the variable from a constant in effect setting a variable to a specified value 205 L - Get the double word from the numbered zmm register and put it in a variable 206 L - Get the quad word from the numbered zmm register and put it in a variable 207 L - Load the variable from the named registers 208 L - Get the word from the numbered zmm register and put it in a variable 209 L - Check whether the left hand variable is greater than the right hand variable 210 L - Increment a variable 211 L - Increment or decrement a variable 212 L - Check whether the specified variable is a reference to another variable 213 L - Check whether the left hand variable is less than or equal to the right hand variable 214 L - Load bytes from the memory addressed by the specified source variable into the numbered zmm register. 215 L - Check whether the left hand variable is less than the right hand variable 216 L - Maximum of two variables 217 L - Minimum of two variables 218 L - Implement minus and assign 219 L - Divide the left hand variable by the right hand variable and return the remainder as a new variable 220 L - Check whether the left hand variable is not equal to the right hand variable 221 L - Or two variables 222 L - Dump the value of a variable on stdout 223 L - Dump the value of a variable on stdout and append a new line 224 L - Implement plus and assign 225 L - Pop a variable from the stack 226 L - Write the memory addressed by a variable to stderr 227 L - Write the memory addressed by a variable to stdout or stderr 228 L - Write the memory addressed by a variable to stdout 229 L - Push a variable onto the stack 230 L - Place the value of the content variable at the byte in the numbered xmm register 231 L - Place the value of the content variable at the byte in the numbered zmm register 232 L - Place the value of the content variable at the byte|word|double word|quad word in the numbered zmm register 233 L - Place the value of the content variable at the double word in the numbered xmm register 234 L - Place the value of the content variable at the double word in the numbered zmm register 235 L - Place the value of the content variable at the quad word in the numbered xmm register 236 L - Place the value of the content variable at the quad word in the numbered zmm register 237 L - Place the value of the content variable at the word in the numbered xmm register 238 L - Place the value of the content variable at the word in the numbered zmm register 239 L - Save bytes into the memory addressed by the target variable from the numbered zmm register. 240 L - Set the mask register to ones starting at the specified position for the specified length and zeroes elsewhere 241 L - Set a bit in the specified mask register retaining the other bits 242 L - Set the first bits in the specified mask register 243 L - Set the named registers from the content of the variable 244 L - Load bytes from the memory addressed by specified source variable into the numbered zmm register at the offset in the specified offset moving the number of bytes in the specified variable 245 L - The name of the variable 246 L - Subtract the right hand variable from the left hand variable and return the result as a new variable 247 L - Multiply the left hand variable by the right hand variable and return the result as a new variable 248 L - Broadcast a double word in a variable into the numbered zmm. 249 L - Open a file, whose name is addressed by rax, for read and return the file descriptor in rax 250 L - Create the file named by the terminated string addressed by rax for write 251 L - Peek at register on stack 252 L - We cannot pop a double word from the stack in 64 bit long mode using pop so we improvise 253 L - Pop registers from the stack 254 L - Pop registers from the stack without tracking 255 L - Print the memory addressed by rax for a length of rdi on stderr 256 L - Dump memory from the address in rax for the length in rdi on stderr 257 L - Dump memory from the address in rax for the length in rdi and then print a new line 258 L - Print the memory addressed by rax for a length of rdi followed by a new line on stderr 259 L - Print a new line to stderr 260 L - Write the content of register rax in hexadecimal in big endian notation to stderr 261 L - Print the named registers as hex strings on stderr 262 L - Print a constant string to stderr. 263 L - Print a constant string followed by a new line to stderr 264 L - Print the zero flag without disturbing it on stderr 265 L - Print the memory addressed by rax for a length of rdi on the specified channel 266 L - Dump memory from the address in rax for the length in rdi on the specified channel. 267 L - Print a new line to stdout or stderr 268 L - Print the memory addressed by rax for a length of rdi on stdout 269 L - Dump memory from the address in rax for the length in rdi on stdout 270 L - Dump memory from the address in rax for the length in rdi and then print a new line 271 L - Print the memory addressed by rax for a length of rdi followed by a new line on stdout 272 L - Print a new line to stderr 273 L - Write the content of register rax in hexadecimal in big endian notation to stderr 274 L - Write the content of register rax to stderr in hexadecimal in little endian notation 275 L - Print the named registers as hex strings on stdout 276 L - Print the general purpose registers in hex 277 L - Print the flags register in hex 278 L - Print the instruction pointer in hex 279 L - Print a constant string to stdout. 280 L - Print a constant string followed by a new line to stdout 281 L - Print the zero flag without disturbing it on stdout 282 L - Write the content of register rax in hexadecimal in big endian notation to the specified channel 283 L - Print the named registers as hex strings 284 L - Print a constant string to the specified channel 285 L - Print the specified number of utf32 characters at the specified address 286 L - Push registers onto the stack 287 L - Push registers onto the stack without tracking 288 L - Layout bytes in the data segment and return their label 289 L - Layout data 290 L - Insert a comment into the read only data segment 291 L - Layout double words in the data segment and return their label 292 L - Read a file whose name is addressed by rax into memory. 293 L - Read the time stamp counter and return the time in nanoseconds in rax 294 L - Return the size of a register 295 L - Return a copy of the specified string with all the non ascii characters removed 296 L - Map the list of registers provided to the 64 bit system call sequence 297 L - Restore the first 4 parameter registers 298 L - Restore the first 4 parameter registers except rax so it can return its value 299 L - Restore the first 4 parameter registers except rax and rdi so we can return a pair of values 300 L - Restore the first 7 parameter registers 301 L - Restore the first 7 parameter registers except rax which is being used to return the result 302 L - Restore the first 7 parameter registers except rax and rdi which are being used to return the results 303 L - Layout quad words in the data segment and return their label 304 L - Layout bytes in read only memory and return their label 305 L - Layout a utf8 encoded string as bytes in read only memory and return their label 306 L - Layout words in the data segment and return their label 307 L - Save the first 4 parameter registers making any parameter registers read only 308 L - Save the first 7 parameter registers 309 L - Create and stack a new scope and continue with it as the current scope 310 L - End the current scope and continue with the containing parent scope 311 L - Set a label in the code section 312 L - Set the length of the short string held in the numbered zmm register into the specified register 313 L - Set the mask register to ones starting at the specified position for the specified length and zeroes elsewhere 314 L - Set the zero flag 315 L - Initialize the assembler 316 L - Stat a file whose name is addressed by rax to get its size in rax 317 L - Length of a zero terminated string 318 L - Create a structure addressed by a register 319 L - Create a subroutine that can be called in assembler code 320 L - Then body for an If statement 321 L - Total size in bytes of all files assembled during testing 322 L - Add tracing code 323 L - Unlink the named file 324 L - Recover the initial values in registers that were reordered 325 L - Create a new variable with the specified size and name initialized via an expression 326 L - Define a byte variable 327 L - Define a double word variable 328 L - Define a quad variable 329 L - Define a reference variable 330 L - Define a word variable 331 L - Define an xmm variable 332 L - Initialize an xyz register from general purpose registers 333 L - Define an ymm variable 334 L - Define an zmm variable 335 L - Wait for the pid in rax to complete 336 L - Add xmm to the front of a list of register expressions 337 L - Add ymm to the front of a list of register expressions 338 L - Add zmm to the front of a list of register expressions =head1 Installation This module is written in 100% Pure Perl and, thus, it is easy to read, comprehend, use, modify and install via B: sudo cpan install Nasm::X86 =head1 Author L L =head1 Copyright Copyright (c) 2016-2021 Philip R Brenan. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. =cut # Tests and documentation sub test {my $p = __PACKAGE__; binmode($_, ":utf8") for *STDOUT, *STDERR; return if eval "eof(${p}::DATA)"; my $s = eval "join('', <${p}::DATA>)"; $@ and die $@; eval $s; $@ and die $@; 1 } test unless caller; 1; # podDocumentation __DATA__ use Time::HiRes qw(time); use Test::Most; bail_on_fail; my $localTest = ((caller(1))[0]//'Nasm::X86') eq "Nasm::X86"; # Local testing mode Test::More->builder->output("/dev/null") if $localTest; # Reduce number of confirmation messages during testing if ($^O =~ m(bsd|linux|cygwin)i) # Supported systems {if (confirmHasCommandLineCommand(q(nasm)) and LocateIntelEmulator) # Network assembler and Intel Software Development emulator {plan tests => 110; } else {plan skip_all => qq(Nasm or Intel 64 emulator not available); } } else {plan skip_all => qq(Not supported on: $^O); } my $start = time; # Tests eval {goto latest} if !caller(0) and -e "/home/phil"; # Go to latest test if specified if (1) { #TPrintOutStringNL #TPrintErrStringNL #TAssemble PrintOutStringNL "Hello World"; PrintOutStringNL "Hello\nWorld"; PrintErrStringNL "Hello World"; ok Assemble(debug => 0, eq => <setReg(rax); Vmovdqu8 "[rax]", xmm0; Mov rdi, 16; PrintOutMemory; PrintOutNL; FreeMemory(address => $address, size=> $N); ok Assemble(eq => < 0, eq => < 0, eq => <setReg(rax); $N->setReg(rdi); PrintOutMemoryInHexNL; FreeMemory($N, $A); ok Assemble(eq => <setReg(rax); # Address of file in memory $s->setReg(rdi); # Length of file in memory PrintOutMemory; # Print contents of memory to stdout my $r = Assemble; # Assemble and execute ok stringMd5Sum($r) eq fileMd5Sum($0); # Output contains this file } #latest:; if (1) { #TCreateByteString #TByteString::clear #TByteString::out #TByteString::copy #TByteString::nl my $a = CreateByteString; # Create a string $a->q('aa'); $a->out; PrintOutNL; is_deeply Assemble, <q('aa'); $b->q('bb'); $a->out; PrintOutNL; $b->out; PrintOutNL; is_deeply Assemble, <q('aa'); $a->q('AA'); $a->out; PrintOutNL; is_deeply Assemble, <q('aa'); $b->q('bb'); $a->q('AA'); $b->q('BB'); $a->q('aa'); $b->q('bb'); $a->out; $b->out; PrintOutNL; is_deeply Assemble, <q('ab'); my $b = CreateByteString; # Create target byte string $b->append(source=>$a->bs); $b->append(source=>$a->bs); $a->append(source=>$b->bs); $b->append(source=>$a->bs); $a->append(source=>$b->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $b->append(source=>$a->bs); $a->out; PrintOutNL; # Print byte string $b->out; PrintOutNL; # Print byte string $a->length(my $sa = Vq(size)); $sa->outNL; $b->length(my $sb = Vq(size)); $sb->outNL; $a->clear; $a->length(my $sA = Vq(size)); $sA->outNL; $b->length(my $sB = Vq(size)); $sB->outNL; is_deeply Assemble, <q("A"); $s->nl; $s->q("B"); $s->out; PrintOutNL; is_deeply Assemble, <read(Vq(file, Rs($0))); $s->out; my $r = Assemble; is_deeply stringMd5Sum($r), fileMd5Sum($0); # Output contains this file } if (1) { # Print rdi in hex into a byte string #TGetPidInHex GetPidInHex; PrintOutRegisterInHex rax; ok Assemble =~ m(rax: 00); } if (1) { # Execute the content of a byte string #TexecuteFileViaBash #TByteString::write #TByteString::out #TunlinkFile #TByteString::ql my $s = CreateByteString; # Create a string $s->ql(<write (my $f = Vq('file', Rs("zzz.sh"))); # Write code to a file executeFileViaBash($f); # Execute the file unlinkFile ($f); # Delete the file my $u = qx(whoami); chomp($u); ok Assemble(emulator=>0) =~ m($u); # The Intel Software Development Emulator is way too slow on these operations. } if (1) { # Make a byte string readonly my $s = CreateByteString; # Create a byte string $s->q("Hello"); # Write code to byte string $s->makeReadOnly; # Make byte string read only $s->q(" World"); # Try to write to byte string ok Assemble(debug=>2) =~ m(SDE ERROR: DEREFERENCING BAD MEMORY POINTER.*mov byte ptr .rax.rdx.1., r8b); } if (1) { # Make a read only byte string writable #TByteString::makeReadOnly #TByteString::makeWriteable my $s = CreateByteString; # Create a byte string $s->q("Hello"); # Write data to byte string $s->makeReadOnly; # Make byte string read only - tested above $s->makeWriteable; # Make byte string writable again $s->q(" World"); # Try to write to byte string $s->out; ok Assemble =~ m(Hello World); } if (1) { # Allocate some space in byte string #TByteString::allocate my $s = CreateByteString; # Create a byte string $s->allocate(Vq(size, 0x20), my $o1 = Vq(offset)); # Allocate space wanted $s->allocate(Vq(size, 0x30), my $o2 = Vq(offset)); $s->allocate(Vq(size, 0x10), my $o3 = Vq(offset)); $o1->outNL; $o2->outNL; $o3->outNL; is_deeply Assemble, < $a); AllocateMemory(Cq(size, $N), my $b = Vq(address)); CopyMemory(source => $a, target => $b, Cq(size, $N)); $b->setReg(rax); Mov rdi, $N; PrintOutMemoryInHexNL; ok Assemble(debug=>0, eq => <outNL; Assemble(debug => 0, eq => <'hash'; # Assemble to the specified file name ok qx($e "") =~ m(r15: 0000 3F80 0000 3F80); # Test well known hashes ok qx($e "a") =~ m(r15: 0000 3F80 C000 45B2); if (0) # Hash various strings {my %r; my %f; my $count = 0; my $N = RegisterSize zmm0; if (1) # Fixed blocks {for my $l(qw(a ab abc abcd), 'a a', 'a a') {for my $i(1..$N) {my $t = $l x $i; last if $N < length $t; my $s = substr($t.(' ' x $N), 0, $N); next if $f{$s}++; my $r = qx($e "$s"); say STDERR "$count $r"; if ($r =~ m(^.*r15:\s*(.*)$)m) {push $r{$1}->@*, $s; ++$count; } } } } if (1) # Variable blocks {for my $l(qw(a ab abc abcd), '', 'a a', 'a a') {for my $i(1..$N) {my $t = $l x $i; next if $f{$t}++; my $r = qx($e "$t"); say STDERR "$count $r"; if ($r =~ m(^.*r15:\s*(.*)$)m) {push $r{$1}->@*, $t; ++$count; } } } } for my $r(keys %r) {delete $r{$r} if $r{$r}->@* < 2; } say STDERR dump(\%r); say STDERR "Keys hashed: ", $count; confess "Duplicates : ", scalar keys(%r); } } if (1) { #TLoadShortStringFromMemoryToZmm my $s = Rb(3, 0x01, 0x02, 0x03); my $t = Rb(7, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a); LoadShortStringFromMemoryToZmm 0, $s; LoadShortStringFromMemoryToZmm 1, $t; ConcatenateShortStrings(0, 1); PrintOutRegisterInHex xmm0; PrintOutRegisterInHex xmm1; my $r = Assemble; ok $r =~ m(xmm0: 0000 0000 000A 0908 0706 0504 0302 010A); ok $r =~ m(xmm1: 0000 0000 0000 0000 0A09 0807 0605 0407); } if (1) { # Concatenate empty string to itself 4 times my $s = Rb(0); LoadShortStringFromMemoryToZmm 0, $s; ConcatenateShortStrings(0, 0); ConcatenateShortStrings(0, 0); ConcatenateShortStrings(0, 0); ConcatenateShortStrings(0, 0); PrintOutRegisterInHex xmm0; ok Assemble =~ m(xmm0: 0000 0000 0000 0000 0000 0000 0000 0000); } if (1) { #Tif #TifEq #TifNe #TifLe #TifLt #TifGe #TifGt my $cmp = sub {my ($a, $b) = @_; for my $op(qw(eq ne lt le gt ge)) {Mov rax, $a; Cmp rax, $b; KeepFree rax; my $Op = ucfirst $op; eval qq(If$Op {PrintOutStringNL("$a $op $b")} sub {PrintOutStringNL("$a NOT $op $b")}); $@ and confess $@; } }; &$cmp(1,1); &$cmp(1,2); &$cmp(3,2); Assemble(debug => 0, eq => <depth, 2; is_deeply $s2->name, q(s2); ScopeEnd; my $t1 = Scope(t1); my $t2 = Scope(t2); is_deeply $t1->depth, 2; is_deeply $t1->name, q(t1); is_deeply $t2->depth, 3; is_deeply $t2->name, q(t2); ok $s1->currentlyVisible; ok !$s2->currentlyVisible; ok $s1->contains($t2); ok !$s2->contains($t2); ScopeEnd; is_deeply $s1->depth, 1; is_deeply $s1->name, q(s1); ScopeEnd; } #latest:; if (1) { #TNasm::X86::Variable::dump #TNasm::X86::Variable::print my $a = Vq(a, 3); $a->outNL; my $b = Vq(b, 2); $b->outNL; my $c = $a + $b; $c->outNL; my $d = $c - $a; $d->outNL; my $e = $d == $b; $e->outNL; my $f = $d != $b; $f->outNL; my $g = $a * $b; $g->outNL; my $h = $g / $b; $h->outNL; my $i = $a % $b; $i->outNL; If ($a == 3, sub{PrintOutStringNL "a == 3"}); ++$a; $a->outNL; --$a; $a->outNL; ok Assemble(debug => 0, eq => <for(sub {my ($i, $start, $next, $end) = @_; $i->outNL; }); is_deeply Assemble, <min($b); my $d = $a->max($b); $a->outNL; $b->outNL; $c->outNL; $d->outNL; is_deeply Assemble,<setMask($length, k7); PrintOutRegisterInHex k7; is_deeply Assemble, <setZmm(0, $offset, $length); } if (1) # Second block {my $offset = Vq(Offset, 33); my $length = Vq(Length, 12); $source->setZmm(0, $offset, $length); } PrintOutRegisterInHex zmm0; is_deeply Assemble, <loadZmm(0); # Show variable in zmm0 $b ->loadZmm(1); # Show variable in zmm1 ($a + $b)->loadZmm(2); # Add bytes and show in zmm2 ($a - $b)->loadZmm(3); # Subtract bytes and show in zmm3 PrintOutRegisterInHex "zmm$_" for 0..3; is_deeply Assemble, <putBIntoZmm(0, 4); $c->putWIntoZmm(0, 6); $c->putDIntoZmm(0, 10); $c->putQIntoZmm(0, 16); PrintOutRegisterInHex zmm0; getBFromZmm(0, 12)->outNL; getWFromZmm(0, 12)->outNL; getDFromZmm(0, 12)->outNL; getQFromZmm(0, 12)->outNL; is_deeply Assemble, <CreateBlockString; $b->append(Vq(source, $s), Vq(size, 3)); $b->dump; $b->append(Vq(source, $s), Vq(size, 4)); $b->dump; $b->append(Vq(source, $s), Vq(size, 5)); $b->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $b->append(Vq(source, $s), Vq(size, 165)); $b->dump; $b->append(Vq(source, $s), Vq(size, 2)); $b->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $b->append(Vq(source, $s), Vq(size, 56)); $b->dump; $b->append(Vq(source, $s), Vq(size, 4)); $b->dump; $b->append(Vq(source, $s), Vq(size, 5)); $b->dump; $b->append(Vq(source, $s), Vq(size, 0)); $b->dump; $b->append(Vq(source, $s), Vq(size, 256)); $b->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $b->append(source=>Vq(source, $s), Vq(size, 256)); $b->len(my $size = Vq(size)); $size->outNL; $b->clear; $b->append(Vq(source, $s), size => Vq(size, 16)); $b->dump; $b->len(my $size2 = Vq(size)); $size2->outNL; is_deeply Assemble, <CreateBlockString; my $T = CreateByteString; my $t = $T->CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 256)); $t->concatenate($s); $t->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 3)); $s->dump; $s->insertChar(character=>Vq(source, 0x44), position => Vq(size, 2)); $s->dump; $s->insertChar(character=>Vq(source, 0x88), position => Vq(size, 2)); $s->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 58)); $s->dump; $s->insertChar(Vq(character, 0x44), Vq(position, 22)); $s->dump; $s->insertChar(Vq(character, 0x88), Vq(position, 22)); $s->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 166)); $s->dump; $s->insertChar(Vq(character, 0x44), Vq(position, 64)); $s->dump; $s->insertChar(Vq(character, 0x88), Vq(position, 64)); $s->dump; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 3)); $s->dump; $s->insertChar(Vq(character, 0x44), Vq(position, 64)); $s->dump; $s->len(my $size = Vq(size)); $size->outNL; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 165)); $s->dump; $s->deleteChar(Vq(position, 0x44)); $s->dump; $s->len(my $size = Vq(size)); $size->outNL; ok Assemble(debug => 0, eq => <CreateBlockString; $s->append(source=>Vq(source, $c), Vq(size, 110)); $s->dump; $s->getCharacter(Vq(position, 0x44), my $out = Vq(out)); $out->outNL; ok Assemble(debug => 0, eq => <setMask($o, k7); PrintOutRegisterInHex k7; $z->setMask($t, k6); PrintOutRegisterInHex k6; $z->setMask($o+$t, k5); PrintOutRegisterInHex k5; $o->setMask($o, k4); PrintOutRegisterInHex k4; $o->setMask($t, k3); PrintOutRegisterInHex k3; $o->setMask($o+$t, k2); PrintOutRegisterInHex k2; $t->setMask($o, k1); PrintOutRegisterInHex k1; $t->setMask($t, k0); PrintOutRegisterInHex k0; ok Assemble(debug => 0, eq => <CreateBlockArray; $a->push(element => Vq($_, $_)) for 1..15; $A->dump; $a->push(element => Vq($_, $_)) for 0xff; $A->dump; $a->push(element => Vq($_, $_)) for 17..31; $A->dump; $a->push(element => Vq($_, $_)) for 0xee; $A->dump; $a->push(element => Vq($_, $_)) for 33..36; $A->dump; ok Assemble(debug => 0, eq => <CreateBlockArray; my $l = Vq(limit, 15); my $L = $l + 5; my sub put # Put a constant or a variable {my ($e) = @_; $a->push(element => (ref($e) ? $e : Vq($e, $e))); }; my sub get # Get a constant or a variable {my ($i) = @_; $a->get(index=>(my $v = ref($i) ? $i : Vq('index', $i)), my $e = Vq(element)); $v->out("index: ", " "); $e->outNL; }; $l->for(sub # Loop to the limit pushing {my ($index, $start, $next, $end) = @_; put($index+1); }); $l->for(sub # Loop to the limit getting {my ($index, $start, $next, $end) = @_; get($index); }); put(16); get(15); $L->for(sub {my ($index, $start, $next, $end) = @_; put($index+$l+2); }); $L->for(sub {my ($index, $start, $next, $end) = @_; get($index + $l + 1); }); if (1) {$a->put(my $i = Vq('index', 9), my $e = Vq(element, 0xFFF9)); get(9); } if (1) {$a->put(my $i = Vq('index', 19), my $e = Vq(element, 0xEEE9)); get(19); } $a->dump; ($l+$L+1)->for(sub {my ($i, $start, $next, $end) = @_; $a->pop(my $e = Vq(element)); $e->outNL; If (($e == 33)|($e == 32)|($e == 17)|($e == 16)|($e == 15)|($e == 14)|($e == 1)|($e == 0), sub {$a->dump; }); }); Vq(limit, 38)->for(sub # Push using a loop and reusing the freed space {my ($index, $start, $next, $end) = @_; $a->push(element=>$index*2); }); $a->dump; Vq(limit, 38)->for(sub # Push using a loop and reusing the freed space {my ($index, $start, $next, $end) = @_; $a->pop(my $e = Vq(element)); $e->outNL; }); $a->dump; ok Assemble(debug => 0, eq => <dump; my $b1 = $a->allocBlock; $a->dump; my $b2 = $a->allocBlock; $a->dump; $a->freeBlock($b2); $a->dump; $a->freeBlock($b1); $a->dump; ok Assemble(debug => 0, eq => <CreateBlockArray; my sub put {my ($e) = @_; $a->push(element => Vq($e, $e)); }; my sub get {my ($i) = @_; # Parameters $a->get(my $v = Vq('index', $i), my $e = Vq(element)); $v->out; PrintOutString " "; $e->outNL; }; put($_) for 1..15; get(15); ok Assemble(debug => 2, eq => < < <k5 # 0000000000001000 G Want broadcast mask !F&A = K5!&k7->k6 Mov eax, 0x007f; Kmovw k7, eax; Mov esi, 0x0F78; Kmovw k6, esi; Kandw k5, k6, k7; Kandnw k4, k5, k7; Kshiftlw k5, k5, 1; Korw k5, k4, k5; Kandnw k6, k5, k7; PrintOutRegisterInHex k7, k5, k6; ok Assemble(eq => <allocBlock; Vmovdqu8 zmm31, "[$format]"; $b->putBlock($b->bs, $a, 31); my $r = $b->chain($b->bs, Vq(start, 0x18), 4); $r->outNL("chain1: "); my $s = $b->chain($b->bs, $r, 4); $s->outNL("chain2: "); my $t = $b->chain($b->bs, $s, 4); $t->outNL("chain3: "); my $A = $b->chain($b->bs, Vq(start, 0x18), 4, 4, 4); $A->outNL("chain4: "); # Get a long chain $b->putChain($b->bs, Vq(start, 0x18), Vq(end, 0xff), 4, 4, 4); # Put at the end of a long chain $b->dump; my $sub = Subroutine {my ($p) = @_; # Parameters If ($$p{c} == -1, sub {PrintOutStringNL "C is minus one"}, sub {PrintOutStringNL "C is NOT minus one"}, ); If ($$p{d} == -1, sub {PrintOutStringNL "D is minus one"}, sub {PrintOutStringNL "D is NOT minus one"}, ); my $C = $$p{c}->clone; $C->outNL; $$p{e} += 1; $$p{e}->outNL('E: '); $$p{f}->outNL('F1: '); $$p{f}++; $$p{f}->outNL('F2: '); } name=> 'aaa', in => {c => 3}, io => {d => 3, e => 3, f => 3}; my $c = Cq(c, -1); my $d = Cq(d, -1); my $e = Vq(e, 1); my $f = Vq(f, 2); $sub->call($c, $d, $e, $f); $f->outNL('F3: '); ok Assemble(debug => 0, eq => <pop; $a->push; $a->outNL; PopEax; PrintRaxInHex($stdout, 3); PrintOutNL; KeepFree rax; ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$Sk]"; Vmovdqu8 zmm30, "[$Sd]"; Vmovdqu8 zmm29, "[$Sn]"; Vmovdqu8 zmm28, "[$sk]"; Vmovdqu8 zmm27, "[$sd]"; Vmovdqu8 zmm26, "[$sn]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullLeftNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$tk]"; Vmovdqu8 zmm30, "[$td]"; Vmovdqu8 zmm29, "[$tn]"; Vmovdqu8 zmm28, "[$lk]"; Vmovdqu8 zmm27, "[$ld]"; Vmovdqu8 zmm26, "[$ln]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullLeftNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$tk]"; Vmovdqu8 zmm30, "[$td]"; Vmovdqu8 zmm29, "[$tn]"; Vmovdqu8 zmm28, "[$lk]"; Vmovdqu8 zmm27, "[$ld]"; Vmovdqu8 zmm26, "[$ln]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullRightNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; Vmovdqu8 zmm31, "[$tk]"; Vmovdqu8 zmm30, "[$td]"; Vmovdqu8 zmm29, "[$tn]"; Vmovdqu8 zmm28, "[$lk]"; Vmovdqu8 zmm27, "[$ld]"; Vmovdqu8 zmm26, "[$ln]"; Vmovdqu8 zmm25, "[$rk]"; Vmovdqu8 zmm24, "[$rd]"; Vmovdqu8 zmm23, "[$rn]"; $t->splitFullRightNode($b->bs); PrintOutRegisterInHex reverse zmm(23..31); ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; my $d = Vq(data); my $f = Vq(found); Vq(count, 24)->for(sub # 24 {my ($index, $start, $next, $end) = @_; my $k = $index + 1; my $d = $k + 0x100; $t->insert(key => $k, data => $d); }); $t->getKeysDataNode($t->first, 31, 30, 29); PrintOutStringNL "Root"; $t->first->outNL('First: '); PrintOutRegisterInHex zmm31, zmm30, zmm29; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0xd8), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x258), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x198), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; $t->by(sub {my ($iter, $end) = @_; $iter->key ->out('key: '); $iter->data->out(' data: '); $iter->tree->depth($iter->node, my $D = Vq(depth)); $t->find(key => $iter->key, $d, $f); $f->out(' found: '); $d->out(' data: '); $D->outNL(' depth: '); }); $t->find(key => Vq(key, 0xffff), $d, $f); $f->outNL('Found: '); $t->find(key => Vq(key, 0xd), $d, $f); $f->outNL('Found: '); ok Assemble(debug => 0, eq => <setMaskBit("k$_"); PrintOutRegisterInHex "k$_"; } ok Assemble(debug => 0, eq => <CreateBlockMultiWayTree; my $d = Vq(data); my $f = Vq(found); my $N = 24; Vq(count, $N)->for(sub {my ($index, $start, $next, $end) = @_; if (1) {my $k = $index * 2 + 1; my $d = $k + 0x100; $t->insert(key => $k, data => $d); } if (1) {my $k = $index * -2 + 2 * $N; my $d = $k + 0x100; $t->insert(key => $k, data => $d); } }); $t->getKeysDataNode($t->first, 31, 30, 29); PrintOutStringNL "Root"; $t->first->outNL('First: '); PrintOutRegisterInHex zmm31, zmm30, zmm29; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x258), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x3d8), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x318), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0xd8), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; KeepFree zmm 26; $t->getKeysDataNode(Vq(offset, 0x198), 28,27,26); PrintOutStringNL "Left"; PrintOutRegisterInHex zmm28, zmm27, zmm26; $t->find(key => Vq(key, 0xffff), $d, $f); $f->outNL('Found: '); $t->find(key => Vq(key, 0x1b), $d, $f); $f->outNL('Found: '); ok Assemble(debug => 0, eq => <$chars, @p; # Dollar UTF-8 Encoding: 0x24 UTF-32 Encoding: 0x00000024 $out->out('out1 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+1, @p; # Cents UTF-8 Encoding: 0xC2 0xA2 UTF-32 Encoding: 0x000000a2 $out->out('out2 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+3, @p; # Alpha UTF-8 Encoding: 0xC9 0x91 UTF-32 Encoding: 0x00000251 $out->out('out3 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+5, @p; # Euro UTF-8 Encoding: 0xE2 0x82 0xAC UTF-32 Encoding: 0x000020AC $out->out('out4 : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$chars+8, @p; # Gothic Letter Hwair UTF-8 Encoding 0xF0 0x90 0x8D 0x88 UTF-32 Encoding: 0x00010348 $out->out('out5 : '); $size->outNL(' size : '); my $statement = qq(๐–บ\n ๐‘Ž๐‘ ๐‘ ๐‘–๐‘”๐‘› ใ€ใ€๐–ป ๐ฉ๐ฅ๐ฎ๐ฌ ๐–ผใ€‘ใ€‘\nAAAAAAAA); # A sample sentence to parse my $s = Cq(statement, Rs($statement)); my $l = Cq(size, length($statement)); AllocateMemory($l, my $address = Vq(address)); # Allocate enough memory for a copy of the string CopyMemory(source => $s, target => $address, $l); GetNextUtf8CharAsUtf32 in=>$address, @p; $out->out('outA : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+4, @p; $out->out('outB : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+5, @p; $out->out('outC : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+30, @p; $out->out('outD : '); $size->outNL(' size : '); GetNextUtf8CharAsUtf32 in=>$address+35, @p; $out->out('outE : '); $size->outNL(' size : '); $address->printOutMemoryInHexNL($l); # Single character classifications Cq('newLine', 0x0A)->putBIntoZmm(0, 0); #r 0x0 - open bracket #r 0x1 - close bracket Cq('newLine', 0x02)->putBIntoZmm(0, 3); #r 0x2 - new line, #r 0x3 - new line acting as a semi-colon Cq('space', 0x20)->putBIntoZmm(0, 4); Cq('space', 0x05)->putBIntoZmm(0, 7); #r 0x5 - space my sub pu32($$) # Print some utf32 characters {my ($n, $m) = @_; # Variable: number of characters to print, variable: address of memory $n->for(sub {my ($index, $start, $next, $end) = @_; my $a = $m + $index * 4; $a->setReg(r15); KeepFree r15; Mov r15d, "[r15]"; KeepFree r15; PrintOutRegisterInHex r15; }); } if (1) # Classify a utf32 string {my $a = Dd(0x0001d5ba, 0x00000020, 0x0001d44e, 0x0000000a, 0x0001d5bb, 0x0001d429); my $t = Cq('test', $a); my $s = Cq('size', 6); ClassifyCharacters4 address=>$t, size=>$s; PrintOutStringNL "Convert some utf8 to utf32"; pu32($s, $t); } # circledLatinLetter : assign โ’ถโ’ทโ’ธโ’นโ’บโ’ปโ’ผโ’ฝโ’พโ’ฟโ“€โ“โ“‚โ“ƒโ“„โ“…โ“†โ“‡โ“ˆโ“‰โ“Šโ“‹โ“Œโ“โ“Žโ“โ“โ“‘โ“’โ““โ“”โ“•โ“–โ“—โ“˜โ“™โ“šโ“›โ“œโ“โ“žโ“Ÿโ“ โ“กโ“ขโ“ฃโ“คโ“ฅโ“ฆโ“งโ“จโ“ฉ # mathematicalBold : dyad lr 3 ๐€๐๐‚๐ƒ๐„๐…๐†๐‡๐ˆ๐‰๐Š๐‹๐Œ๐๐Ž๐๐๐‘๐’๐“๐”๐•๐–๐—๐˜๐™๐š๐›๐œ๐๐ž๐Ÿ๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐šจ๐šฉ๐šช๐šซ๐šฌ๐šญ๐šฎ๐šฏ๐šฐ๐šฑ๐šฒ๐šณ๐šด๐šต๐šถ๐šท๐šธ๐šบ๐šป๐šผ๐šฝ๐šพ๐šฟ๐›€๐›‚๐›ƒ๐›„๐›…๐›†๐›‡๐›ˆ๐›‰๐›Š๐›‹๐›Œ๐›๐›Ž๐›๐›๐›‘๐›’๐›”๐›•๐›–๐›—๐›˜๐›™๐›š๐ŸŠ๐Ÿ‹ # mathematicalBoldFraktur : ๐•ฌ๐•ญ๐•ฎ๐•ฏ๐•ฐ๐•ฑ๐•ฒ๐•ณ๐•ด๐•ต๐•ถ๐•ท๐•ธ๐•น๐•บ๐•ป๐•ผ๐•ฝ๐•พ๐•ฟ๐–€๐–๐–‚๐–ƒ๐–„๐–…๐–†๐–‡๐–ˆ๐–‰๐–Š๐–‹๐–Œ๐–๐–Ž๐–๐–๐–‘๐–’๐–“๐–”๐–•๐––๐–—๐–˜๐–™๐–š๐–›๐–œ๐–๐–ž๐–Ÿ # mathematicalBoldItalic : prefix ๐‘จ๐‘ฉ๐‘ช๐‘ซ๐‘ฌ๐‘ญ๐‘ฎ๐‘ฏ๐‘ฐ๐‘ฑ๐‘ฒ๐‘ณ๐‘ด๐‘ต๐‘ถ๐‘ท๐‘ธ๐‘น๐‘บ๐‘ป๐‘ผ๐‘ฝ๐‘พ๐‘ฟ๐’€๐’๐’‚๐’ƒ๐’„๐’…๐’†๐’‡๐’ˆ๐’‰๐’Š๐’‹๐’Œ๐’๐’Ž๐’๐’๐’‘๐’’๐’“๐’”๐’•๐’–๐’—๐’˜๐’™๐’š๐’›๐œœ๐œ๐œž๐œŸ๐œ ๐œก๐œข๐œฃ๐œค๐œฅ๐œฆ๐œง๐œจ๐œฉ๐œช๐œซ๐œฌ๐œฎ๐œฏ๐œฐ๐œฑ๐œฒ๐œณ๐œด๐œถ๐œท๐œธ๐œน๐œบ๐œป๐œผ๐œฝ๐œพ๐œฟ๐€๐๐‚๐ƒ๐„๐…๐†๐ˆ๐‰๐Š๐‹๐Œ๐๐Ž # mathematicalBoldScript : ๐“๐“‘๐“’๐““๐“”๐“•๐“–๐“—๐“˜๐“™๐“š๐“›๐“œ๐“๐“ž๐“Ÿ๐“ ๐“ก๐“ข๐“ฃ๐“ค๐“ฅ๐“ฆ๐“ง๐“จ๐“ฉ๐“ช๐“ซ๐“ฌ๐“ญ๐“ฎ๐“ฏ๐“ฐ๐“ฑ๐“ฒ๐“ณ๐“ด๐“ต๐“ถ๐“ท๐“ธ๐“น๐“บ๐“ป๐“ผ๐“ฝ๐“พ๐“ฟ๐”€๐”๐”‚๐”ƒ # mathematicalDouble-struck : ๐”ธ๐”น๐”ป๐”ผ๐”ฝ๐”พ๐•€๐•๐•‚๐•ƒ๐•„๐•†๐•Š๐•‹๐•Œ๐•๐•Ž๐•๐•๐•’๐•“๐•”๐••๐•–๐•—๐•˜๐•™๐•š๐•›๐•œ๐•๐•ž๐•Ÿ๐• ๐•ก๐•ข๐•ฃ๐•ค๐•ฅ๐•ฆ๐•ง๐•จ๐•ฉ๐•ช๐•ซ # mathematicalFraktur : ๐”„๐”…๐”‡๐”ˆ๐”‰๐”Š๐”๐”Ž๐”๐”๐”‘๐”’๐”“๐””๐”–๐”—๐”˜๐”™๐”š๐”›๐”œ๐”ž๐”Ÿ๐” ๐”ก๐”ข๐”ฃ๐”ค๐”ฅ๐”ฆ๐”ง๐”จ๐”ฉ๐”ช๐”ซ๐”ฌ๐”ญ๐”ฎ๐”ฏ๐”ฐ๐”ฑ๐”ฒ๐”ณ๐”ด๐”ต๐”ถ๐”ท # mathematicalItalic : ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐‘€๐‘๐‘‚๐‘ƒ๐‘„๐‘…๐‘†๐‘‡๐‘ˆ๐‘‰๐‘Š๐‘‹๐‘Œ๐‘๐‘Ž๐‘๐‘๐‘‘๐‘’๐‘“๐‘”๐‘–๐‘—๐‘˜๐‘™๐‘š๐‘›๐‘œ๐‘๐‘ž๐‘Ÿ๐‘ ๐‘ก๐‘ข๐‘ฃ๐‘ค๐‘ฅ๐‘ฆ๐‘ง๐›ข๐›ฃ๐›ค๐›ฅ๐›ฆ๐›ง๐›จ๐›ฉ๐›ช๐›ซ๐›ฌ๐›ญ๐›ฎ๐›ฏ๐›ฐ๐›ฑ๐›ฒ๐›ด๐›ต๐›ถ๐›ท๐›ธ๐›น๐›บ๐›ผ๐›ฝ๐›พ๐›ฟ๐œ€๐œ๐œ‚๐œƒ๐œ„๐œ…๐œ†๐œ‡๐œˆ๐œ‰๐œŠ๐œ‹๐œŒ๐œŽ๐œ๐œ๐œ‘๐œ’๐œ“๐œ” # mathematicalMonospace : ๐™ฐ๐™ฑ๐™ฒ๐™ณ๐™ด๐™ต๐™ถ๐™ท๐™ธ๐™น๐™บ๐™ป๐™ผ๐™ฝ๐™พ๐™ฟ๐š€๐š๐š‚๐šƒ๐š„๐š…๐š†๐š‡๐šˆ๐š‰๐šŠ๐š‹๐šŒ๐š๐šŽ๐š๐š๐š‘๐š’๐š“๐š”๐š•๐š–๐š—๐š˜๐š™๐šš๐š›๐šœ๐š๐šž๐šŸ๐š ๐šก๐šข๐šฃ # mathematicalSans-serif : variable ๐– ๐–ก๐–ข๐–ฃ๐–ค๐–ฅ๐–ฆ๐–ง๐–จ๐–ฉ๐–ช๐–ซ๐–ฌ๐–ญ๐–ฎ๐–ฏ๐–ฐ๐–ฑ๐–ฒ๐–ณ๐–ด๐–ต๐–ถ๐–ท๐–ธ๐–น๐–บ๐–ป๐–ผ๐–ฝ๐–พ๐–ฟ๐—€๐—๐—‚๐—ƒ๐—„๐—…๐—†๐—‡๐—ˆ๐—‰๐—Š๐—‹๐—Œ๐—๐—Ž๐—๐—๐—‘๐—’๐—“ # mathematicalSans-serifBold : ๐—”๐—•๐—–๐——๐—˜๐—™๐—š๐—›๐—œ๐—๐—ž๐—Ÿ๐— ๐—ก๐—ข๐—ฃ๐—ค๐—ฅ๐—ฆ๐—ง๐—จ๐—ฉ๐—ช๐—ซ๐—ฌ๐—ญ๐—ฎ๐—ฏ๐—ฐ๐—ฑ๐—ฒ๐—ณ๐—ด๐—ต๐—ถ๐—ท๐—ธ๐—น๐—บ๐—ป๐—ผ๐—ฝ๐—พ๐—ฟ๐˜€๐˜๐˜‚๐˜ƒ๐˜„๐˜…๐˜†๐˜‡๐–๐—๐˜๐™๐š๐›๐œ๐๐ž๐Ÿ๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐ž€๐ž‚๐žƒ๐ž„๐ž…๐ž†๐ž‡๐žˆ # mathematicalSans-serifBoldItalic : postfix ๐˜ผ๐˜ฝ๐˜พ๐˜ฟ๐™€๐™๐™‚๐™ƒ๐™„๐™…๐™†๐™‡๐™ˆ๐™‰๐™Š๐™‹๐™Œ๐™๐™Ž๐™๐™๐™‘๐™’๐™“๐™”๐™•๐™–๐™—๐™˜๐™™๐™š๐™›๐™œ๐™๐™ž๐™Ÿ๐™ ๐™ก๐™ข๐™ฃ๐™ค๐™ฅ๐™ฆ๐™ง๐™จ๐™ฉ๐™ช๐™ซ๐™ฌ๐™ญ๐™ฎ๐™ฏ๐ž๐ž‘๐ž’๐ž“๐ž”๐ž•๐ž–๐ž—๐ž˜๐ž™๐žš๐ž›๐žœ๐ž๐žž๐žŸ๐ž ๐žข๐žฃ๐žค๐žฅ๐žฆ๐žง๐žจ๐žช๐žซ๐žฌ๐žญ๐žฎ๐žฏ๐žฐ๐žฑ๐žฒ๐žณ๐žด๐žต๐žถ๐žท๐žธ๐žน๐žบ๐žผ๐žฝ๐žพ๐žฟ๐Ÿ€๐Ÿ๐Ÿ‚ # mathematicalSans-serifItalic : ๐˜ˆ๐˜‰๐˜Š๐˜‹๐˜Œ๐˜๐˜Ž๐˜๐˜๐˜‘๐˜’๐˜“๐˜”๐˜•๐˜–๐˜—๐˜˜๐˜™๐˜š๐˜›๐˜œ๐˜๐˜ž๐˜Ÿ๐˜ ๐˜ก๐˜ข๐˜ฃ๐˜ค๐˜ฅ๐˜ฆ๐˜ง๐˜จ๐˜ฉ๐˜ช๐˜ซ๐˜ฌ๐˜ญ๐˜ฎ๐˜ฏ๐˜ฐ๐˜ฑ๐˜ฒ๐˜ณ๐˜ด๐˜ต๐˜ถ๐˜ท๐˜ธ๐˜น๐˜บ๐˜ป # mathematicalScript : ๐’œ๐’ž๐’Ÿ๐’ข๐’ฅ๐’ฆ๐’ฉ๐’ช๐’ซ๐’ฌ๐’ฎ๐’ฏ๐’ฐ๐’ฑ๐’ฒ๐’ณ๐’ด๐’ต๐’ถ๐’ท๐’ธ๐’น๐’ป๐’ฝ๐’พ๐’ฟ๐“€๐“๐“‚๐“ƒ๐“…๐“†๐“‡๐“ˆ๐“‰๐“Š๐“‹๐“Œ๐“๐“Ž๐“ # negativeCircledLatinLetter : ๐Ÿ…๐Ÿ…‘๐Ÿ…’๐Ÿ…“๐Ÿ…”๐Ÿ…•๐Ÿ…–๐Ÿ…—๐Ÿ…˜๐Ÿ…™๐Ÿ…š๐Ÿ…›๐Ÿ…œ๐Ÿ…๐Ÿ…ž๐Ÿ…Ÿ๐Ÿ… ๐Ÿ…ก๐Ÿ…ข๐Ÿ…ฃ๐Ÿ…ค๐Ÿ…ฅ๐Ÿ…ฆ๐Ÿ…ง๐Ÿ…จ๐Ÿ…ฉ # negativeSquaredLatinLetter : ๐Ÿ…ฐ๐Ÿ…ฑ๐Ÿ…ฒ๐Ÿ…ณ๐Ÿ…ด๐Ÿ…ต๐Ÿ…ถ๐Ÿ…ท๐Ÿ…ธ๐Ÿ…น๐Ÿ…บ๐Ÿ…ป๐Ÿ…ผ๐Ÿ…ฝ๐Ÿ…พ๐Ÿ…ฟ๐Ÿ†€๐Ÿ†๐Ÿ†‚๐Ÿ†ƒ๐Ÿ†„๐Ÿ†…๐Ÿ††๐Ÿ†‡๐Ÿ†ˆ๐Ÿ†‰ # squaredLatinLetter : ๐Ÿ„ฐ๐Ÿ„ฑ๐Ÿ„ฒ๐Ÿ„ณ๐Ÿ„ด๐Ÿ„ต๐Ÿ„ถ๐Ÿ„ท๐Ÿ„ธ๐Ÿ„น๐Ÿ„บ๐Ÿ„ป๐Ÿ„ผ๐Ÿ„ฝ๐Ÿ„พ๐Ÿ„ฟ๐Ÿ…€๐Ÿ…๐Ÿ…‚๐Ÿ…ƒ๐Ÿ…„๐Ÿ……๐Ÿ…†๐Ÿ…‡๐Ÿ…ˆ๐Ÿ…‰๐Ÿ†ฅ # semiColon : semicolon โŸข # Delete following code when the following test is completed if (0) # Convert utf8 test string to utf32 {my @p = my ($u32, $size32, $count) = (Vq(u32), Vq(size32), Vq(count)); ClassifyCharacters4 address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - special characters"; pu32($count, $u32); Cq('variable', 0x0) ->putDIntoZmm(0, 0); # Range classifications Cq('variable', 0x06) ->putBIntoZmm(0, 3); #r 0x6 - ascii Cq('variable', 0x01D5A0)->putDIntoZmm(0, 4); Cq('variable', 0x07) ->putBIntoZmm(0, 7); #r 0x7 - variable Cq('variable', 0x01D434)->putDIntoZmm(0, 8); Cq('variable', 0x08) ->putBIntoZmm(0, 11); #r 0x8 - assign Cq('variable', 0x01D400)->putDIntoZmm(0, 12); Cq('variable', 0x09) ->putBIntoZmm(0, 15); #r 0x9 - Cq('variable', 0x7f) ->putDIntoZmm(1, 0); Cq('variable', 0x06) ->putBIntoZmm(1, 3); Cq('variable', 0x01D5D3)->putDIntoZmm(1, 4); Cq('variable', 0x07) ->putBIntoZmm(1, 7); Cq('variable', 0x01D467)->putDIntoZmm(1, 8); Cq('variable', 0x08) ->putBIntoZmm(1, 11); Cq('variable', 0x01D433)->putDIntoZmm(1, 12); Cq('variable', 0x09) ->putBIntoZmm(1, 15); ClassifyInRange address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - ranges"; pu32($count, $u32); my $bl = Rd(0x10002045, 0x12002329, 0x1400276c, 0x16002770, 0x1c0027e6, 0x24002983, 0x26002987, 0x380029fc, 0x3a003008, 0x3e003010, 0x40003014, 0x4800ff3b, 0x4900ff3d, 0x4a00ff5b, 0x4b00ff5d, 0); my $bh = Rd(0x11002046, 0x1300232a, 0x1500276d, 0x1b002775, 0x230027ed, 0x25002984, 0x37002998, 0x390029fd, 0x3d00300b, 0x3f003011, 0x4700301b, 0x4800ff3b, 0x4900ff3d, 0x4a00ff5b, 0x4b00ff5d, 0); Vmovdqu8 zmm0, "[$bl]"; Vmovdqu8 zmm1, "[$bh]"; ClassifyWithInRange address=>$u32, size=>$count; PrintOutStringNL "Convert test statement - brackets"; pu32($count, $u32); MatchBrackets address=>$u32, size=>$count, $opens, $fail; PrintOutStringNL "Convert test statement - bracket matching"; pu32($count, $u32); } $address->clearMemory($l); $address->printOutMemoryInHexNL($l); ok Assemble(debug => 0, eq => <1), <