Program crppro;
{$B-,S-,R-,Q-}                     { mssen so sein! }
uses dos;
Type dword=longint;                 {seufz, leider}
Type string2=string[2];
Type string8=string[8];
Type Bytearray=array[0..7] of Byte;

const KB=1024; MB=KB*KB; GB=MB*KB;
const Proterror:boolean=false;
const UC=0; WC=1; WT=4; WP=5; WB=6;
const nstr:array[0..6] of string2=('UC','WC','??','??','WT','WP','WB');

var alt0D:pointer;

Procedure cli           ; inline ($FA);
Procedure WBINVD        ; inline ($0F/$09);

Procedure errorexit (fehler:string; nr:integer);
  begin Writeln (fehler); halt(nr) end;

Function Hexb (zahl:Byte):string2;
Const Ziffern:Array[0..15] of char='0123456789ABCDEF';
Begin
  hexb[0]:=#2;
  hexb[1]:=Ziffern[zahl shr 4];
  hexb[2]:=Ziffern[zahl and $0F];
end;

Function hexl(x:dword):string8;
var bf:array[0..3] of byte absolute x;
begin
hexl:=hexb(bf[3])+hexb(bf[2])+hexb(bf[1])+hexb(bf[0]);
end;

procedure Int0D(Flags, CS, IP, AX, BX, CX, DX,
                       SI, DI, DS, ES, BP: word);
interrupt;
begin
 inc (ip,2);
 Proterror:=true;
end;

procedure getMSR (ecx:dword; var eax,edx:dword);

begin
 proterror:=false;
 getintvec ($0D,alt0D);
 cli;
 setintvec ($0D,@int0D);
 asm
   db $66; mov cx,word ptr [ecx]
   db $0F,$32
   les di,eax
   db $66; mov word ptr es:di,ax
   les di,edx
   db $66; mov word ptr es:di,dx
 end;
 setintvec($0D,alt0D);
 if proterror then errorexit('Oh Schreck, Schutzverletzung',2);
end;

procedure setMSR (ecx:dword; eax,edx:dword; setInt:boolean);

begin
 proterror:=false;
 if setint then begin
  getintvec ($0D,alt0D);
  cli;
  setintvec ($0D,@int0D);
 end;
 asm
   db $66; mov ax, word ptr [eax]
   db $66; mov dx, word ptr [edx]
   db $66; mov cx, word ptr [ecx]
   db $0F,$30
 end;
 if setint then setintvec($0D,alt0D);
 if proterror then errorexit('Oh Schreck, Schutzverletzung',3);
end;

Procedure ToggleCR0(mask:dword);
begin
 asm
 db $0F,$20,$C0
 db $66; xor ax, word ptr mask
 db $0F,$22,$C0
 end;
end;

Procedure ClearICache; { TLB & ICache lschen }
begin
inline ($0F/$20/$D8);         { MOV EAX,CR3      }
inline ($0F/$22/$D8)          { MOV CR3,EAX      }
end;

Procedure SetMTRR (ecx:dword; eax,edx:dword);
var MTRRdefType,res:dword;
begin
 getmsr ($2FF,MTRRdefType,res);
 getintvec ($0D,alt0D);
 cli;
 setintvec ($0D,@int0D);
 ToggleCR0 ($40000000);                           { Cache Freeze }
 WBINVD;
 ClearICache;
 setmsr($2FF,MTRRdeftype and not $800,res,false); { Disable MTRR }
 setmsr(ecx,eax,edx,false);
 setmsr($2FF,MTRRdeftype or $800,res,false);      { Enable MTRR }
 ClearICache;
 ToggleCR0($40000000);
 setintvec($0D,alt0D);
end;

Function attrib (x:byte):string2;
begin
 if x <=6 then attrib:=nstr[x] else attrib:='??'
end;

Procedure Noblank(var s:string);
var t:string; i:integer;
begin
t:='';
for i:=1 to length(s) do if s[i] <>' ' then t:=t+upcase(s[i]);
s:=t;
end;

Function str2attr(s:string):byte;
var i:integer;
begin
Noblank(s);
for i:=0 to 6 do if s=nstr[i] then
 begin str2attr:=i; exit end;
errorexit('unbekanntes Attribut',2);
end;

Procedure showfixmemattr (MSR:dword;baseadr,size:dword);
var i:integer;
    fattr:byte;
    var edx,eax:dword;
    var bfeld:bytearray absolute eax;
begin
 getmsr(Msr,eax,edx);
 fattr:=bfeld[0];
 i:=0;
 repeat
 inc (i);
 Write (hexl (baseadr+(i-1)*size));
 while (i< 8) and (bfeld[i]=fattr) do inc (i);
 Writeln ('..',hexl (baseadr+i*size-1),':',attrib(fattr):3);
 if i < 8 then fattr:=bfeld[i];
 until i=8;
end;

Procedure showVarimemattr (MSR:dword);
var i:integer;
var Lobase,Hibase,LoMask,HiMask:dword;
var Baseadr, Physmask,Range:dword;
var fattr:Byte;

begin
 getmsr(Msr,loBase,Hibase);
 getmsr(Msr+1,loMask,Himask);
 if not odd(Lomask shr 11) then  exit; { not Valid }
 fattr:=LoBase and $0F;
 Baseadr := Lobase and $FFFFF000;  { Beschrnkt auf 4 Gbyte }
 Physmask:= Lomask and $FFFFF000;  { Beschrnkt auf 4 GByte }
 Range:=4*KB;                     { kleinste Einheit }
 While (Range <> 0) and
       ((Physmask and range) = 0) do range:=range shl 1;
 Write ((msr-$200) div 2,':');
 Write (hexl (baseadr),'..');
 Write (hexl (baseadr+range-1));
 Write (': ',attrib (fattr));
 Writeln (baseadr shr 20:5,' MB .. ',(baseadr+range) shr 20:5,' MB');
end;

Procedure ShowMTRR;
var i:dword;
    MTRRcap,MTRRdefType:dword;
    res:dword;
    VCNT:byte;         { Anzahl der variablen Range Register }
    Defaulttyp:byte;
    Fixmem, WriteCombine, MTRRenable, FixRangeenable:boolean;
begin
  Writeln ('Pentium Pro Memory Type Range Register ',
           'c''t 10/96, V1.0, Andreas Stiller ');
  {**** Auswertung von MTRRcap ****** }
  getmsr($FE,MTRRcap,res);
  WriteCombine:=odd(MTRRCap shr 10);
  Fixmem      :=odd(MTRRCap shr 8);
  VCNT        :=MTRRCap and $0F;
  Write ('Processor supports:');
  If WriteCombine then Write ('Write-Combining, ');
  If Fixmem       then Write ('Fixed Range Regs,');
  Writeln (VCNT:2,' Variable Range Regs');

  {**** Auswertung von MTRRdefType ****** }
  getmsr ($2FF,MTRRdefType,res);
  Defaulttyp:=MTRRdefType and $0F;
  FixRangeenable:=odd(MTRRdefType shr 10);
  MTRRenable:=odd(MTRRdefType shr 11);
  Write ('MTRRs :');
  If MTRRenable then Write ('enabled') else Write
   ('disabled');
  Write (', Fix Range Register :');
  If Fixrangeenable then Write ('enabled') else Writeln ('disabled');
  Writeln (', Default Memory Type: ',attrib(Defaulttyp));
  If Fixmem then begin
  {**** Auswertung der Fix Range Register ****** }
   Writeln ('Memory Attribute in the Range 00000..FFFFF');
   Showfixmemattr ($250,$00000,64*KB);         { 8 Bereiche  64 KByte }
   Showfixmemattr ($258,$80000,16*KB );        { 8 Bereiche  16 KByte }
   Showfixmemattr ($259,$A0000,16*KB );        { 8 Bereiche  16 KByte }
   For i:=0 to 7 do
    Showfixmemattr ($268+i,$C0000+i*32*KB,4*KB);{ 8 Bereiche  4 KByte }
  end;
  If VCNT > 0 then begin
   {**** Auswertung der Variable Range Register ****** }
   Writeln ('Variable Memory Attributs');
   For i:=0 to VCNT-1 do Showvarimemattr($200+2*i);
  end;
end;

Procedure SetVGA (x:byte);
var eax,edx:dword;
    i:integer;
begin
eax:=0;
for i:=1 to 4 do eax:=eax shl 8 or x;
edx:=eax;
setmtrr($259, eax,edx);
end;

Function gethex(s:string):longint;
var result:integer; x:longint;
var lastchar:char;
begin
 noblank(s);
 lastchar:=s[length(s)];
 if lastchar in ['K','M','G'] then val (copy (s,1,length(s)-1),x,result)
                              else val ('$'+s,x,result);
 if result > 0 then errorexit ('Fehler bei Eingabe',1);
 case lastchar of
 'K': x:=x*KB; 'M': x:=x*MB; 'G': x:=x*GB; end;
 gethex:=x;
end;

var zeile,basestr,sizestr:string;
var p,q,attr:byte;
var base,size,mask:dword;
var result,nr,para:integer;
begin
 para:=1;
 repeat
  if paramcount=0 then begin
   ShowMTRR;
   Writeln;
   Writeln ('V[:xx] -- VGA-Area A0000-BFFFF to xx (xx=UC,WC,WT,WP,WB)');
   Writeln ('[Nr/]base,size[:xx] -- for variable Range');
   Readln (Zeile);
  end
  else Zeile:=paramstr(para);
  If zeile='' then halt;
  attr:=WC;
  q:=pos(':',zeile);
  if q=0 then q:=255 else attr:=str2attr(copy(zeile,q+1,255));
  case upcase(zeile[1]) of
  'V' : setVGA (attr);             { VGA-Bereich  setzen }
  'S' : ShowMTRR;                  { Speicherbel. anzeigen }
  'M' : setMSR($1E0,0,0,true);     { Fast Strings setzen }
  else  begin                      { Variable Range Reg setzen }
   p:=pos ('/',zeile);
   if p=0 then Nr:=1
    else begin
    nr:=gethex(copy(zeile,1,p-1));
    delete (zeile,1,p);
    q:=pos(':',zeile); if q=0 then q:=255;
    end;
   p:=pos (',',zeile);
   basestr:=copy(zeile,1,p-1);   base:=gethex(basestr);
   sizestr:=copy(zeile,p+1,q-p-1); size:=gethex(sizestr);
   mask:=$80000000;
   while mask and size = 0 do mask:=(mask shr 1) or $80000000;
   setmtrr ($200+2*nr,base+attr,0);
   setmtrr ($200+2*nr+1,mask+$800,$F);
   end;
  end;
  if para<= paramcount then inc (para);
until (paramcount > 0) and (para> paramcount);
end.






