~james/scope

feat(paging): walk four-level tables and predict access faults

commit
149423fc8891152959ae927d11751f26a4042733 browse tree
parent
b1b249cd6fbbce57ed295d729b9efc69513686bd
author
james <j@cpl0.zip>
signature
Verified ~james signed with a key registered by ~james
date
2026-10-16 17:42 UTC

1 files changed, +140 −0

lib/paging.ml added

@@ -0,0 +1,140 @@
1+open Model
2+
3+type entry = Absent | Invalid of string | Table of Address.Physical.t | Leaf of int * Address.Physical.t
4+
5+let shift level = 12 + (9 * (level - 1))
6+let span level = Int64.shift_left 1L (shift level)
7+
8+let decode features ~nxe ~level raw =
9+ let open Address in
10+ if not (bit raw 0) then Absent
11+ else if bit raw 63 && not nxe then Invalid "nx bit with nxe disabled"
12+ else if Int64.logand raw (Int64.logand (mask 52) (Int64.lognot (mask features.phys_bits))) <> 0L then
13+ Invalid "physical address uses reserved high bits"
14+ else if level = 4 && bit raw 7 then Invalid "page size bit in pml4 entry"
15+ else if level = 3 && bit raw 7 && not features.gb_pages then Invalid "1 gib pages are not exposed to the guest"
16+ else
17+ let address = Int64.logand raw (Int64.logand (mask features.phys_bits) (Int64.lognot 0xfffL)) in
18+ if level = 1 then Leaf (12, Physical.of_int64 address)
19+ else if bit raw 7 then
20+ let bits = shift level in
21+ (* huge leaf: [ frame | reserved | pat | flags ], bit 12 stays out of the frame *)
22+ if Int64.logand raw (Int64.logand (mask bits) (Int64.lognot 0x1fffL)) <> 0L then
23+ Invalid "misaligned huge page uses reserved address bits"
24+ else Leaf (bits, Physical.of_int64 (align address bits))
25+ else Table (Physical.of_int64 address)
26+
27+let error_code context request ~present ~reserved =
28+ (if present then 1 else 0)
29+ lor (if request.access = Write then 2 else 0)
30+ lor (if request.privilege = User then 4 else 0)
31+ lor (if reserved then 8 else 0)
32+ lor (if request.access = Execute &&
33+ (Address.bit context.registers.efer 11 || Address.bit context.registers.cr4 20) then 16 else 0)
34+
35+let walk context read address =
36+ validate context;
37+ let virtual_raw = Address.Virtual.to_int64 address in
38+ if not (Address.canonical virtual_raw) then
39+ { trace = []; outcome = Fault { vector = 13; error_code = 0; reason = "noncanonical linear address"; level = None } }
40+ else
41+ let rec go level table permissions trace =
42+ match read table with
43+ | Error reason -> { trace = List.rev trace; outcome = Incomplete reason }
44+ | Ok page when String.length page <> 4096 ->
45+ { trace = List.rev trace; outcome = Incomplete "table read is not 4096 bytes" }
46+ | Ok page ->
47+ let index = Int64.(to_int (logand (shift_right_logical virtual_raw (shift level)) 511L)) in
48+ let raw = String.get_int64_le page (index * 8) in
49+ let effective = narrow permissions raw in
50+ let step = { level; table; index; raw; effective } in
51+ let trace = step :: trace in
52+ match decode context.features ~nxe:(Address.bit context.registers.efer 11) ~level raw with
53+ | Absent -> { trace = List.rev trace; outcome = Fault {
54+ vector = 14; error_code = 0; reason = "entry not present"; level = Some level } }
55+ | Invalid reason -> { trace = List.rev trace; outcome = Fault {
56+ vector = 14; error_code = 9; reason; level = Some level } }
57+ | Table next -> go (level - 1) next effective trace
58+ | Leaf (bits, base) ->
59+ let trace = List.rev trace in
60+ let physical_address = Address.Physical.of_int64
61+ Int64.(add (Address.Physical.to_int64 base) (logand virtual_raw (Address.mask bits))) in
62+ { trace; outcome = Mapped { virtual_address = address; physical_address;
63+ size = Int64.shift_left 1L bits; permissions = effective; leaf = raw; trace } }
64+ in
65+ go 4 (root context) unrestricted []
66+
67+let explain context read address request =
68+ let result = walk context read address in
69+ let fault reason level =
70+ { result with outcome = Fault { vector = 14;
71+ error_code = error_code context request ~present:true ~reserved:false;
72+ reason; level } }
73+ in
74+ match result.outcome with
75+ | Incomplete _ -> result
76+ | Fault f when f.vector = 13 -> result
77+ | Fault f -> { result with outcome = Fault { f with error_code =
78+ error_code context request ~present:(f.error_code land 1 <> 0)
79+ ~reserved:(f.error_code land 8 <> 0) } }
80+ | Mapped mapping ->
81+ let p = mapping.permissions and r = context.registers in
82+ let first predicate =
83+ List.find_opt predicate result.trace |> Option.map (fun (step : step) -> step.level)
84+ in
85+ if request.privilege = User && not p.user then
86+ fault "supervisor mapping denies user access" (first (fun s -> not (Address.bit s.raw 2)))
87+ else if request.access = Write && not p.writable &&
88+ (request.privilege = User || Address.bit r.cr0 16) then
89+ fault "read-only entry denies write" (first (fun s -> not (Address.bit s.raw 1)))
90+ else if request.access = Execute && not p.executable then
91+ fault "nx entry denies instruction fetch" (first (fun s -> Address.bit s.raw 63))
92+ else if request.privilege = Supervisor && p.user && request.access = Execute && Address.bit r.cr4 20 then
93+ fault "smep denies supervisor fetch from user mapping" None
94+ else if request.privilege = Supervisor && p.user && request.access <> Execute &&
95+ Address.bit r.cr4 21 && not request.ac then
96+ fault "smap denies explicit supervisor data access with ac clear" None
97+ else result
98+
99+type state = Present of mapping | Unknown of string | Broken of string
100+type region = { start : int64; length : int64; state : state }
101+
102+let last region = Int64.pred (Int64.add region.start region.length)
103+
104+let enumerate ?(max_entries = 2_000_000) context read =
105+ validate context;
106+ let count = ref 0 and acc = ref [] in
107+ let emit start length state = acc := { start; length; state } :: !acc in
108+ let canonicalise x =
109+ if Address.bit x 47 then Int64.logor x 0xffff000000000000L else x
110+ in
111+ let rec go level table prefix permissions trace =
112+ match read table with
113+ | Error reason ->
114+ if level = 4 then begin
115+ emit 0L 0x800000000000L (Unknown reason);
116+ emit 0xffff800000000000L 0x800000000000L (Unknown reason)
117+ end else emit (canonicalise prefix) (Int64.mul 512L (span level)) (Unknown reason)
118+ | Ok page ->
119+ if String.length page <> 4096 then invalid_arg "table read is not 4096 bytes";
120+ for index = 0 to 511 do
121+ incr count;
122+ if !count > max_entries then raise (Limit "page-table traversal budget exceeded");
123+ let raw = String.get_int64_le page (index * 8) in
124+ let prefix = Int64.logor prefix (Int64.shift_left (Int64.of_int index) (shift level)) in
125+ let start = canonicalise prefix in
126+ let effective = narrow permissions raw in
127+ let trace = { level; table; index; raw; effective } :: trace in
128+ match decode context.features ~nxe:(Address.bit context.registers.efer 11) ~level raw with
129+ | Absent -> ()
130+ | Invalid reason -> emit start (span level) (Broken reason)
131+ | Table next -> go (level - 1) next prefix effective trace
132+ | Leaf (bits, physical_address) ->
133+ let trace = List.rev trace in
134+ let mapping = { virtual_address = Address.Virtual.of_int64 start; physical_address;
135+ size = Int64.shift_left 1L bits; permissions = effective; leaf = raw; trace } in
136+ emit start mapping.size (Present mapping)
137+ done
138+ in
139+ go 4 (root context) 0L unrestricted [];
140+ List.rev !acc