with Ada.Numerics.Discrete_Random; with Ada.Unchecked_Conversion; with Ada.Command_Line; with Interfaces.C; with HW.Time; with HW.Debug; with HW.PCI.Dev; with HW.MMIO_Range; with HW.GFX.GMA; with HW.GFX.GMA.Config; with HW.GFX.GMA.Display_Probing; package body HW.GFX.GMA.GFX_Test is pragma Disable_Atomic_Synchronization; Primary_Delay_MS : constant := 8_000; Secondary_Delay_MS : constant := 4_000; HP_Delay_MS : constant := 500; Seed : constant := 12345; package Rand_P is new Ada.Numerics.Discrete_Random (Natural); function Rand (Gen : Rand_P.Generator) return Int32 is (Int32 (Rand_P.Random (Gen))); Start_X : constant := 0; Start_Y : constant := 0; package Dev is new PCI.Dev (PCI.Address'(0, 2, 0)); type GTT_Entry is record Addr : GTT_Address_Type; Valid : Boolean; end record; GTT_Backup : array (GTT_Range) of GTT_Entry; procedure Backup_GTT is begin for Idx in GTT_Range loop Read_GTT (GTT_Backup (Idx).Addr, GTT_Backup (Idx).Valid, Idx); end loop; end Backup_GTT; procedure Restore_GTT is begin for Idx in GTT_Range loop Write_GTT (Idx, GTT_Backup (Idx).Addr, GTT_Backup (Idx).Valid); end loop; end Restore_GTT; type Pixel_Type is record Red : Byte; Green : Byte; Blue : Byte; Alpha : Byte; end record; for Pixel_Type use record Blue at 0 range 0 .. 7; Green at 1 range 0 .. 7; Red at 2 range 0 .. 7; Alpha at 3 range 0 .. 7; end record; White : constant Pixel_Type := (255, 255, 255, 255); Black : constant Pixel_Type := ( 0, 0, 0, 255); Red : constant Pixel_Type := (255, 0, 0, 255); Green : constant Pixel_Type := ( 0, 255, 0, 255); Blue : constant Pixel_Type := ( 0, 0, 255, 255); function Pixel_To_Word (P : Pixel_Type) return Word32 with SPARK_Mode => Off is function To_Word is new Ada.Unchecked_Conversion (Pixel_Type, Word32); begin return To_Word (P); end Pixel_To_Word; Max_W : constant := 4096; Max_H : constant := 2160; FB_Align : constant := 16#0004_0000#; Cursor_Align : constant := 16#0001_0000#; Max_Cursor_Wid : constant := 256; subtype Screen_Index is Natural range 0 .. 3 * (Max_W * Max_H + FB_Align / 4 + 3 * Max_Cursor_Wid * Max_Cursor_Wid + Cursor_Align / 4) - 1; type Screen_Type is array (Screen_Index) of Word32; function Screen_Offset (FB : Framebuffer_Type) return Natural is (Natural (Phys_Offset (FB) / 4)); package Screen is new MMIO_Range (0, Word32, Screen_Index, Screen_Type); Screen_Backup : Screen_Type; procedure Backup_Screen (FB : Framebuffer_Type) is First : constant Screen_Index := Screen_Offset (FB); Last : constant Screen_Index := First + Natural (FB_Size (FB)) / 4 - 1; begin for Idx in Screen_Index range First .. Last loop Screen.Read (Screen_Backup (Idx), Idx); end loop; end Backup_Screen; procedure Restore_Screen (FB : Framebuffer_Type) is First : constant Screen_Index := Screen_Offset (FB); Last : constant Screen_Index := First + Natural (FB_Size (FB)) / 4 - 1; begin for Idx in Screen_Index range First .. Last loop Screen.Write (Idx, Screen_Backup (Idx)); end loop; end Restore_Screen; function Drawing_Width (FB : Framebuffer_Type) return Natural is (Natural (FB.Width + 2 * Start_X)); function Drawing_Height (FB : Framebuffer_Type) return Natural is (Natural (FB.Height + 2 * Start_Y)); function Corner_Fill (X, Y : Natural; FB : Framebuffer_Type; Pipe : Pipe_Index) return Pixel_Type is Xrel : constant Integer := (if X < 32 then X else X - (Drawing_Width (FB) - 32)); Yrel : constant Integer := (if Y < 32 then Y else Y - (Drawing_Height (FB) - 32)); function Color (Idx : Natural) return Pixel_Type is (case (Idx + Pipe_Index'Pos (Pipe)) mod 4 is when 0 => Blue, when 1 => Black, when 3 => Green, when others => Red); begin return (if Xrel mod 16 = 0 or Xrel = 31 or Yrel mod 16 = 0 or Yrel = 31 then White elsif Yrel < 16 then (if Xrel < 16 then Color (0) else Color (1)) else (if Xrel < 16 then Color (3) else Color (2))); end Corner_Fill; function Fill (X, Y : Natural; Framebuffer : Framebuffer_Type; Pipe : Pipe_Index) return Pixel_Type is use type HW.Byte; Xp : constant Natural := X * 256 / Drawing_Width (Framebuffer); Yp : constant Natural := Y * 256 / Drawing_Height (Framebuffer); Xn : constant Natural := 255 - Xp; Yn : constant Natural := 255 - Yp; function Map (X, Y : Natural) return Byte is begin return Byte (X * Y / 255); end Map; begin return (case Pipe is when GMA.Primary => (Map (Xn, Yn), Map (Xp, Yn), Map (Xp, Yp), 255), when GMA.Secondary => (Map (Xn, Yp), Map (Xn, Yn), Map (Xp, Yn), 255), when GMA.Tertiary => (Map (Xp, Yp), Map (Xn, Yp), Map (Xn, Yn), 255)); end Fill; procedure Test_Screen (Framebuffer : Framebuffer_Type; Pipe : GMA.Pipe_Index) is P : Pixel_Type; -- We have pixel offset wheras the framebuffer has a byte offset Offset_Y : Natural := Screen_Offset (Framebuffer); Offset : Natural; function Top_Test (X, Y : Natural) return Boolean is C : constant Natural := Drawing_Width (Framebuffer) / 2; S_Y : constant Natural := 3 * (Y - Start_Y) / 2; Left : constant Integer := X - C + S_Y; Right : constant Integer := X - C - S_Y; begin return (Y - Start_Y) < 12 and ((-1 <= Left and Left <= 0) or (0 <= Right and Right <= 1)); end Top_Test; begin for Y in 0 .. Drawing_Height (Framebuffer) - 1 loop Offset := Offset_Y; for X in 0 .. Drawing_Width (Framebuffer) - 1 loop if (X < 32 or X >= Drawing_Width (Framebuffer) - 32) and (Y < 32 or Y >= Drawing_Height (Framebuffer) - 32) then P := Corner_Fill (X, Y, Framebuffer, Pipe); elsif Framebuffer.Rotation /= No_Rotation and then Top_Test (X, Y) then P := White; elsif Y mod 16 = 0 or X mod 16 = 0 then P := Black; else P := Fill (X, Y, Framebuffer, Pipe); end if; Screen.Write (Offset, Pixel_To_Word (P)); Offset := Offset + 1; end loop; Offset_Y := Offset_Y + Natural (Framebuffer.Stride); end loop; end Test_Screen; function Donut (X, Y, Max : Cursor_Pos) return Byte is ZZ : constant Int32 := Max * Max * 2; Dist_Center : constant Int32 := ((X * X + Y * Y) * 255) / ZZ; Dist_Circle : constant Int32 := Dist_Center - 20; begin return Byte (255 - Int32'Min (255, 6 * abs Dist_Circle + 64)); end Donut; procedure Draw_Cursor (Pipe : Pipe_Index; Cursor : Cursor_Type) is use type HW.Byte; Width : constant Width_Type := Cursor_Width (Cursor.Size); Screen_Offset : Natural := Natural (Shift_Left (Word32 (Cursor.GTT_Offset), 12) / 4); begin if Cursor.Mode /= ARGB_Cursor then return; end if; for Y in Cursor_Pos range -Width / 2 .. Width / 2 - 1 loop for X in Cursor_Pos range -Width / 2 .. Width / 2 - 1 loop declare D : constant Byte := Donut (X, Y, Width / 2); begin -- Hardware seems to expect pre-multiplied alpha (i.e. -- color components already contain the alpha). Screen.Write (Index => Screen_Offset, Value => Pixel_To_Word ( (Red => (if Pipe = Secondary then D / 2 else 0), Green => (if Pipe = Tertiary then D / 2 else 0), Blue => (if Pipe = Primary then D / 2 else 0), Alpha => D))); Screen_Offset := Screen_Offset + 1; end; end loop; end loop; end Draw_Cursor; procedure Calc_Framebuffer (FB : out Framebuffer_Type; Mode : in Mode_Type; Rotation : in Rotation_Type; Offset : in out Word32) is Width : constant Width_Type := Mode.H_Visible; Height : constant Height_Type := Mode.V_Visible; begin Offset := (Offset + FB_Align - 1) and not (FB_Align - 1); if Rotation = Rotated_90 or Rotation = Rotated_270 then FB := (Width => Height, Height => Width, Start_X => Start_X, Start_Y => Start_Y, BPC => 8, Stride => Div_Round_Up (Height + 2 * Start_X, 32) * 32, V_Stride => Div_Round_Up (Width + 2 * Start_Y, 32) * 32, Tiling => Y_Tiled, Rotation => Rotation, Offset => Offset + Word32 (GTT_Rotation_Offset) * GTT_Page_Size); else FB := (Width => Width, Height => Height, Start_X => Start_X, Start_Y => Start_Y, BPC => 8, Stride => Div_Round_Up (Width + 2 * Start_X, 16) * 16, V_Stride => Height + 2 * Start_Y, Tiling => Linear, Rotation => Rotation, Offset => Offset); end if; Offset := Offset + Word32 (FB_Size (FB)); end Calc_Framebuffer; type Cursor_Array is array (Cursor_Size) of Cursor_Type; Cursors : array (Pipe_Index) of Cursor_Array; procedure Prepare_Cursors (Cursors : out Cursor_Array; Offset : in out Word32) is GMA_Phys_Base : constant PCI.Index := 16#5c#; GMA_Phys_Base_Mask : constant := 16#fff0_0000#; Phys_Base : Word32; Success : Boolean; begin Dev.Read32 (Phys_Base, GMA_Phys_Base); Phys_Base := Phys_Base and GMA_Phys_Base_Mask; Success := Phys_Base /= GMA_Phys_Base_Mask and Phys_Base /= 0; if not Success then Debug.Put_Line ("Failed to read stolen memory base."); return; end if; for Size in Cursor_Size loop Offset := (Offset + Cursor_Align - 1) and not (Cursor_Align - 1); declare Width : constant Width_Type := Cursor_Width (Size); GTT_End : constant Word32 := Offset + Word32 (Width * Width) * 4; begin Cursors (Size) := (Mode => ARGB_Cursor, Size => Size, Center_X => Width, Center_Y => Width, GTT_Offset => GTT_Range (Shift_Right (Offset, 12))); while Offset < GTT_End loop GMA.Write_GTT (GTT_Page => GTT_Range (Offset / GTT_Page_Size), Device_Address => GTT_Address_Type (Phys_Base + Offset), Valid => True); Offset := Offset + GTT_Page_Size; end loop; end; end loop; end Prepare_Cursors; Pipes : GMA.Pipe_Configs; procedure Prepare_Configs (Rotation : Rotation_Type; Gen : Rand_P.Generator) is use type HW.GFX.GMA.Port_Type; Offset : Word32 := 0; Success : Boolean; begin GMA.Display_Probing.Scan_Ports (Pipes); for Pipe in GMA.Pipe_Index loop if Pipes (Pipe).Port /= GMA.Disabled then Calc_Framebuffer (FB => Pipes (Pipe).Framebuffer, Mode => Pipes (Pipe).Mode, Rotation => Rotation, Offset => Offset); GMA.Setup_Default_FB (FB => Pipes (Pipe).Framebuffer, Clear => False, Success => Success); if not Success then Pipes (Pipe).Port := GMA.Disabled; end if; end if; Prepare_Cursors (Cursors (Pipe), Offset); Pipes (Pipe).Cursor := Cursors (Pipe) (Cursor_Size'Val (Rand (Gen) mod 3)); end loop; GMA.Dump_Configs (Pipes); end Prepare_Configs; procedure Script_Cursors (Pipes : in out GMA.Pipe_Configs; Hotplug_List : out Display_Probing.Port_List; Total_Deadline : in Time.T; Time_MS : in Natural) is type Corner is (UL, UR, LR, LL); type Cursor_Script_Entry is record Rel : Corner; X, Y : Int32; end record; Cursor_Script : constant array (Natural range 0 .. 19) of Cursor_Script_Entry := ((UL, 16, 16), (UL, 16, 16), (UL, 16, 16), (UL, -32, 0), (UL, 16, 16), (UR, -16, 16), (UR, -16, 16), (UR, -16, 16), (UR, 0, -32), (UR, -16, 16), (LR, -16, -16), (LR, -16, -16), (LR, -16, -16), (LR, 32, 0), (LR, -16, -16), (LL, 16, -16), (LL, 16, -16), (LL, 16, -16), (LL, 0, 32), (LL, 16, -16)); Deadline : constant Time.T := Time.MS_From_Now (Time_MS); HP_Deadline : Time.T := Time.MS_From_Now (HP_Delay_MS); Timed_Out : Boolean := False; Cnt : Word32 := 0; begin Hotplug_List := (others => Disabled); loop for Pipe in Pipe_Index loop exit when Pipes (Pipe).Port = GMA.Disabled; declare C : Cursor_Type renames Pipes (Pipe).Cursor; FB : Framebuffer_Type renames Pipes (Pipe).Framebuffer; Width : constant Width_Type := Rotated_Width (FB); Height : constant Height_Type := Rotated_Height (FB); CS : Cursor_Script_Entry renames Cursor_Script (Natural (Cnt) mod (Cursor_Script'Last + 1)); begin C.Center_X := CS.X; C.Center_Y := CS.Y; case CS.Rel is when UL => null; when UR => C.Center_X := CS.X + Width; when LR => C.Center_X := CS.X + Width; C.Center_Y := CS.Y + Height; when LL => C.Center_Y := CS.Y + Height; end case; GMA.Place_Cursor (Pipe, C.Center_X, C.Center_Y); end; end loop; Timed_Out := Time.Timed_Out (HP_Deadline); if Timed_Out then HP_Deadline := Time.MS_From_Now (HP_Delay_MS); GMA.Display_Probing.Hotplug_Events (Hotplug_List); if Hotplug_List (Hotplug_List'First) /= Disabled then return; end if; end if; Timed_Out := Time.Timed_Out (Total_Deadline); exit when Timed_Out; Timed_Out := Time.Timed_Out (Deadline); exit when Timed_Out; Time.M_Delay (160); Cnt := Cnt + 1; end loop; end Script_Cursors; type Cursor_Info is record X_Velo, Y_Velo : Int32; X_Acc, Y_Acc : Int32; Color : Pipe_Index; Size : Cursor_Size; end record; function Cursor_Rand (Gen : Rand_P.Generator) return Int32 is (Rand (Gen) mod 51 - 25); Cursor_Infos : array (Pipe_Index) of Cursor_Info; procedure Move_Cursors (Pipes : in out GMA.Pipe_Configs; Hotplug_List : out Display_Probing.Port_List; Total_Deadline : in Time.T; Time_MS : in Natural; Gen : in Rand_P.Generator) is procedure Select_New_Cursor (P : in Pipe_Index; C : in out Cursor_Type; CI : in out Cursor_Info) is Old_C : constant Cursor_Type := C; begin -- change either size or color if Rand (Gen) mod 2 = 0 then CI.Color := Pipe_Index'Val ((Pipe_Index'Pos (CI.Color) + 1 + Rand (Gen) mod 2) mod 3); else CI.Size := Cursor_Size'Val ((Cursor_Size'Pos (CI.Size) + 1 + Rand (Gen) mod 2) mod 3); end if; C := Cursors (CI.Color) (CI.Size); C.Center_X := Old_C.Center_X; C.Center_Y := Old_C.Center_Y; GMA.Update_Cursor (P, C); end Select_New_Cursor; Deadline : constant Time.T := Time.MS_From_Now (Time_MS); HP_Deadline : Time.T := Time.MS_From_Now (HP_Delay_MS); Timed_Out : Boolean := False; Cnt : Word32 := 0; begin Hotplug_List := (others => Disabled); for Pipe in Pipe_Index loop exit when Pipes (Pipe).Port = GMA.Disabled; Select_New_Cursor (Pipe, Pipes (Pipe).Cursor, Cursor_Infos (Pipe)); end loop; loop for Pipe in Pipe_Index loop exit when Pipes (Pipe).Port = GMA.Disabled; declare C : Cursor_Type renames Pipes (Pipe).Cursor; CI : Cursor_Info renames Cursor_Infos (Pipe); FB : Framebuffer_Type renames Pipes (Pipe).Framebuffer; Width : constant Width_Type := Rotated_Width (FB); Height : constant Height_Type := Rotated_Height (FB); Update : Boolean := False; begin if Cnt mod 16 = 0 then CI.X_Acc := Cursor_Rand (Gen); CI.Y_Acc := Cursor_Rand (Gen); end if; CI.X_Velo := CI.X_Velo + CI.X_Acc; CI.Y_Velo := CI.Y_Velo + CI.Y_Acc; C.Center_X := C.Center_X + CI.X_Velo / 100; C.Center_Y := C.Center_Y + CI.Y_Velo / 100; if C.Center_X not in 0 .. Width - 1 then C.Center_X := Int32'Max (0, Int32'Min (Width, C.Center_X)); CI.X_Velo := -CI.X_Velo; Update := True; end if; if C.Center_Y not in 0 .. Height - 1 then C.Center_Y := Int32'Max (0, Int32'Min (Height, C.Center_Y)); CI.Y_Velo := -CI.Y_Velo; Update := True; end if; if Update then Select_New_Cursor (Pipe, C, CI); else GMA.Place_Cursor (Pipe, C.Center_X, C.Center_Y); end if; end; end loop; Timed_Out := Time.Timed_Out (HP_Deadline); if Timed_Out then HP_Deadline := Time.MS_From_Now (HP_Delay_MS); GMA.Display_Probing.Hotplug_Events (Hotplug_List); if Hotplug_List (Hotplug_List'First) /= Disabled then return; end if; end if; Timed_Out := Time.Timed_Out (Total_Deadline); exit when Timed_Out; Timed_Out := Time.Timed_Out (Deadline); exit when Timed_Out; Time.M_Delay (16); -- ~60 fps Cnt := Cnt + 1; end loop; end Move_Cursors; procedure Run_The_Show (Deadline : Time.T; Gen : Rand_P.Generator) is Timed_Out : Boolean; Hotplug_List : GMA.Display_Probing.Port_List; New_Pipes : GMA.Pipe_Configs := Pipes; function Rand_Div (Num : Position_Type) return Position_Type is (case Rand (Gen) mod 4 is when 3 => Rand (Gen) mod Num / 3, when 2 => Rand (Gen) mod Num / 2, when 1 => Rand (Gen) mod Num, when others => 0); begin for Pipe in GMA.Pipe_Index loop if Pipes (Pipe).Port /= GMA.Disabled then Test_Screen (Framebuffer => Pipes (Pipe).Framebuffer, Pipe => Pipe); end if; for Size in Cursor_Size loop Draw_Cursor (Pipe, Cursors (Pipe) (Size)); end loop; end loop; Cursor_Infos := (others => (Color => Pipe_Index'Val (Rand (Gen) mod 3), Size => Cursor_Size'Val (Rand (Gen) mod 3), X_Velo => 3 * Cursor_Rand (Gen), Y_Velo => 3 * Cursor_Rand (Gen), others => Cursor_Rand (Gen))); Script_Cursors (Pipes, Hotplug_List, Deadline, Primary_Delay_MS); if Hotplug_List (Hotplug_List'First) /= Disabled then return; end if; Timed_Out := Time.Timed_Out (Deadline); if Timed_Out then return; end if; Rand_P.Reset (Gen, Seed); loop GMA.Display_Probing.Hotplug_Events (Hotplug_List); if Hotplug_List (Hotplug_List'First) /= Disabled then return; end if; New_Pipes := Pipes; for Pipe in GMA.Pipe_Index loop exit when Pipes (Pipe).Port = Disabled; declare New_FB : Framebuffer_Type renames New_Pipes (Pipe).Framebuffer; Cursor : Cursor_Type renames New_Pipes (Pipe).Cursor; Width : constant Width_Type := Pipes (Pipe).Framebuffer.Width; Height : constant Height_Type := Pipes (Pipe).Framebuffer.Height; begin New_FB.Start_X := Position_Type'Min (Width - 320, Rand_Div (Width)); New_FB.Start_Y := Position_Type'Min (Height - 320, Rand_Div (Height)); New_FB.Width := Width_Type'Max (320, Width - New_FB.Start_X - Rand_Div (Width)); New_FB.Height := Height_Type'Max (320, Height - New_FB.Start_Y - Rand_Div (Height)); Cursor.Center_X := Rotated_Width (New_FB) / 2; Cursor.Center_Y := Rotated_Height (New_FB) / 2; GMA.Update_Cursor (Pipe, Cursor); end; end loop; GMA.Dump_Configs (New_Pipes); GMA.Update_Outputs (New_Pipes); Move_Cursors (New_Pipes, Hotplug_List, Deadline, Secondary_Delay_MS, Gen); exit when Hotplug_List (Hotplug_List'First) /= Disabled; Timed_Out := Time.Timed_Out (Deadline); exit when Timed_Out; end loop; end Run_The_Show; procedure Print_Usage is begin Debug.Put_Line ("Usage: " & Ada.Command_Line.Command_Name & " " & " [(0|90|180|270)]"); Debug.New_Line; end Print_Usage; procedure Main is use type HW.GFX.GMA.Port_Type; use type HW.Word64; use type Interfaces.C.int; Res_Addr : Word64; Delay_MS : Natural; Rotation : Rotation_Type := No_Rotation; Dev_Init, Initialized : Boolean; Gen : Rand_P.Generator; Deadline : Time.T; Timed_Out : Boolean; Hotplug_List : GMA.Display_Probing.Port_List; function iopl (level : Interfaces.C.int) return Interfaces.C.int; pragma Import (C, iopl, "iopl"); begin if Ada.Command_Line.Argument_Count < 1 then Print_Usage; return; end if; Delay_MS := Natural'Value (Ada.Command_Line.Argument (1)) * 1_000; if Ada.Command_Line.Argument_Count >= 2 then declare Rotation_Degree : constant String := Ada.Command_Line.Argument (2); begin if Rotation_Degree = "0" then Rotation := No_Rotation; elsif Rotation_Degree = "90" then Rotation := Rotated_90; elsif Rotation_Degree = "180" then Rotation := Rotated_180; elsif Rotation_Degree = "270" then Rotation := Rotated_270; else Print_Usage; return; end if; end; end if; if iopl (3) /= 0 then Debug.Put_Line ("Failed to change i/o privilege level."); return; end if; Dev.Initialize (Dev_Init); if not Dev_Init then Debug.Put_Line ("Failed to map PCI config."); return; end if; Dev.Map (Res_Addr, PCI.Res2, WC => True); if Res_Addr = 0 then Debug.Put_Line ("Failed to map PCI resource2."); return; end if; Screen.Set_Base_Address (Res_Addr); GMA.Initialize (Clean_State => True, Success => Initialized); if Initialized then Backup_GTT; Deadline := Time.MS_From_Now (Delay_MS); loop Prepare_Configs (Rotation, Gen); GMA.Update_Outputs (Pipes); if not (for all P in Pipe_Index => Pipes (P).Port = Disabled) then for Pipe in GMA.Pipe_Index loop if Pipes (Pipe).Port /= GMA.Disabled then Backup_Screen (Pipes (Pipe).Framebuffer); end if; end loop; Run_The_Show (Deadline, Gen); for Pipe in GMA.Pipe_Index loop if Pipes (Pipe).Port /= GMA.Disabled then Restore_Screen (Pipes (Pipe).Framebuffer); end if; end loop; else loop Time.M_Delay (HP_Delay_MS); GMA.Display_Probing.Hotplug_Events (Hotplug_List); exit when Hotplug_List (Hotplug_List'First) /= Disabled; Timed_Out := Time.Timed_Out (Deadline); exit when Timed_Out; end loop; end if; Timed_Out := Time.Timed_Out (Deadline); exit when Timed_Out; end loop; Restore_GTT; end if; end Main; end HW.GFX.GMA.GFX_Test;