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
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101

type features = { phys_bits : int; nx : bool; gb_pages : bool }

type registers = {
  cr0 : int64;
  cr2 : int64;
  cr3 : int64;
  cr4 : int64;
  efer : int64;
  rflags : int64;
  rip : int64;
}

type context = {
  registers : registers;
  root_override : int64 option;
  features : features;
  source : string;
  consistency : string;
  identity : string;
  domid : int;
  vcpu : int;
}

type permissions = { writable : bool; user : bool; executable : bool }
type access = Read | Write | Execute
type privilege = Supervisor | User
type request = { access : access; privilege : privilege; ac : bool }

type step = {
  level : int;
  table : Address.Physical.t;
  index : int;
  raw : int64;
  effective : permissions;
}

type mapping = {
  virtual_address : Address.Virtual.t;
  physical_address : Address.Physical.t;
  size : int64;
  permissions : permissions;
  leaf : int64;
  trace : step list;
}

type fault = {
  vector : int;
  error_code : int;
  reason : string;
  level : int option;
}

type outcome = Mapped of mapping | Fault of fault | Incomplete of string
type result = { trace : step list; outcome : outcome }
type reader = Address.Physical.t -> (string, string) Stdlib.result

exception Limit of string

let unrestricted = { writable = true; user = true; executable = true }

let narrow permissions raw = {
  writable = permissions.writable && Address.bit raw 1;
  user = permissions.user && Address.bit raw 2;
  executable = permissions.executable && not (Address.bit raw 63);
}

let validate context =
  let r = context.registers and f = context.features in
  let require predicate reason = if not predicate then invalid_arg reason in
  require (Sys.word_size = 64) "scope requires a 64-bit runtime";
  require (f.phys_bits >= 32 && f.phys_bits <= 52) "physical width must be between 32 and 52";
  require (Address.bit r.cr0 0 && Address.bit r.cr0 31) "protected paging must be enabled";
  require (Address.bit r.cr4 5 && Address.bit r.efer 10) "only ia-32e paging is supported";
  require (not (Address.bit r.cr4 12)) "five-level paging is unsupported";
  require (not (Address.bit r.cr4 22 || Address.bit r.cr4 24)) "protection keys are unsupported";
  require (not (Address.bit r.cr4 23)) "cet is unsupported";
  require (not (Address.bit r.cr4 27)) "linear address space separation is unsupported";
  require (not (Address.bit r.cr4 28)) "supervisor linear address masking is unsupported";
  require (not (Address.bit r.efer 11) || f.nx) "nxe requires the guest nx feature";
  let validate_root root =
    require (Int64.logand root (Int64.lognot (Address.mask f.phys_bits)) = 0L)
      "cr3 exceeds the physical width or uses unsupported address masking"
  in
  validate_root r.cr3;
  Option.iter validate_root context.root_override;
  require (context.domid >= 0 && context.vcpu >= 0) "negative domain or vcpu"

let root context = Address.Physical.of_int64
  (Address.align (Option.value context.root_override ~default:context.registers.cr3) 12)
let access_name = function Read -> "read" | Write -> "write" | Execute -> "execute"
let privilege_name = function Supervisor -> "supervisor" | User -> "user"

let context_changes before after =
  let a = before.registers and b = after.registers in
  List.filter_map (fun (changed, field) -> if changed then Some field else None) [
    (a.cr0 <> b.cr0, "cr0"); (a.cr3 <> b.cr3, "cr3"); (a.cr4 <> b.cr4, "cr4");
    (root before <> root after, "root");
    (a.efer <> b.efer, "efer"); (Address.bit a.rflags 18 <> Address.bit b.rflags 18, "ac");
    (before.features.phys_bits <> after.features.phys_bits, "phys_bits");
    (before.features.nx <> after.features.nx, "nx");
    (before.features.gb_pages <> after.features.gb_pages, "gb_pages") ]