administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(rtl): FreeBSD libc-free threads + TLS (Step 4c)

Browse source 
The last Step-4 slice: real POSIX threads for a static FreeBSD build,
plus the TLS setup Step 3 deferred (threads need per-thread %fs TLS, and
the main thread needs it too for threadvar access).

runtime.syscall.freebsd gains four FreeBSD-specific leaves (all numbers
verified against release/14.0.0 sys/sys/syscall.h): sysarch=165 (set the
%fs base for TLS via AMD64_SET_FSBASE=129, passing a POINTER to the base
value), _umtx_op=454 (the futex analogue), thr_new=455 (the clone
analogue), thr_exit=431 (terminate ONE thread — NOT exit(2)/SYS_exit,
which kills the process).

runtime.start.static.freebsd gains the full TLS machinery from its Linux
sibling: the auxv PT_TLS walk (AT_PHDR/PHENT/PHNUM and PT_TLS are the same
values on FreeBSD as Linux), the variant-II block build, BuildThreadTLS/
FreeThreadTLS, and _BlaiseStartC now calls SetupTLS(auxv) before main.
The one difference from Linux: the %fs base is set via
sysarch(AMD64_SET_FSBASE, @base) rather than arch_prctl(ARCH_SET_FS, base).

runtime.thread.static.freebsd (new) is the FreeBSD sibling of
runtime.thread.static.linux — it DEFINES the bare pthread_* names the RTL
imports.  The 3-state Drepper mutex (CAS/Xchg) is target-invariant and
copied verbatim; only the wait/wake primitive is swapped
futex -> _umtx_op(UMTX_OP_WAIT_UINT_PRIVATE=15 / WAKE_PRIVATE=16).  Thread
create fills a 104-byte struct thr_param at the amd64 offsets
(start_func@0 arg@8 stack_base@16 stack_size@24 tls_base@32 tls_size@40
child_tid@48 parent_tid@56 flags@64 rtp@72), memset-zeroed first so flags/
rtp/spare are 0, and calls thr_new.  child_tid/parent_tid point at an
Int64 (FreeBSD long*, not Linux's 4-byte).  FreeBSD has no
CLONE_CHILD_CLEARTID, so join uses a dedicated JoinWord: the child
trampoline runs StartRoutine, sets JoinWord:=1, _umtx_op-wakes it, then
thr_exit(nil); pthread_join _umtx_op-waits while JoinWord=0.

Both new/edited units are standalone (nothing in the Linux build graph
uses them), so the Linux self-host is untouched.  Test
TestLink_FreeBSDThreadLeaf_SyscallNumbers asserts thr_new(455)/_umtx_op
(454)/thr_exit(431) bytes are present and Linux's clone(56)/futex(202)
are absent.  Step 4 (the FreeBSD syscall leaf) is now complete.
This commit is contained in:
Graeme Geldenhuys 2026-07-01 09:49:30 +01:00
parent bded5294d5
commit 0a9b79dd30
4 changed files with 696 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

236
compiler/src/main/pascal/runtime.start.static.freebsd.pas
View file

@ -9,38 +9,243 @@
unit runtime.start.static.freebsd;
// Freestanding _start for a static, libc-free FreeBSD ET_EXEC (the FreeBSD
// kernel-leaf swap; docs/freebsd-x86_64-backend-design.adoc, Step 3).
// kernel-leaf swap; docs/freebsd-x86_64-backend-design.adoc, Step 3/4c).
//
// The FreeBSD sibling of runtime.start.static.linux. A tiny asm trampoline
// captures the initial stack pointer and tail-calls the Pascal _BlaiseStartC,
// which parses argc / argv / envp off the kernel's initial stack, captures
// `environ`, calls main(argc, argv), and exits via the FreeBSD `exit` syscall.
// which:
// 1. parses argc / argv / envp / the auxv (the kernel's initial stack);
// 2. sets up the static TLS block and the thread pointer (%fs) — required
// before any threadvar (%fs-relative) access, which a static binary's
// kernel does NOT do for us;
// 3. captures `environ`;
// 4. calls main(argc, argv);
// 5. exits via the FreeBSD `exit` syscall (main itself calls exit, so this
// is a guard).
//
// FreeBSD's process entry stack has the SAME shape as Linux: %rsp points at
// argc, followed by argv[0..argc-1], a NULL, envp[], a NULL, then the ELF auxv.
// (FreeBSD additionally passes an rtld cleanup pointer in %rdx for dynamic
// binaries; it is 0 for a static ET_EXEC and we ignore it.)
//
// Step 3 is deliberately minimal: it does NOT set up TLS / the thread pointer.
// A trivial program performs no threadvar (%fs-relative) access, so this start
// runs hello-world and file I/O. TLS-block construction + the auxv PT_TLS walk
// (whose FreeBSD AT_* tags differ from Linux) arrive with the threads leaf in
// Step 4, mirroring how runtime.start.static.linux gained TLS alongside its
// threads work.
// The ELF auxv PT_TLS walk is PORTABLE: the AT_* tags (AT_PHDR=3, AT_PHENT=4,
// AT_PHNUM=5, AT_NULL=0) and PT_TLS=7 are identical on FreeBSD 14 (elf_common.h)
// and Linux, and x86-64 TLS is variant II on both. The ONE FreeBSD difference
// is how the %fs base is installed: Linux uses arch_prctl(ARCH_SET_FS, tp);
// FreeBSD uses sysarch(AMD64_SET_FSBASE, &tp) — note it takes a POINTER to the
// base value, not the value itself.
//
// x86-64 TLS (variant II): the thread pointer points at the TCB, which sits
// ABOVE the TLS block; threadvars are at negative offsets from the TP. %fs:0
// must hold the TP value itself (the TCB self-pointer). Layout we build:
// [ TLS block: memsz bytes ][ TCB: 8-byte self-pointer ]
// tp = block + memsz_aligned ; %fs = tp ; *(void**)tp = tp.
interface
uses
runtime.syscall.freebsd; { _exit + the `environ` global }
runtime.syscall.freebsd; { _exit, sysarch, mmap/munmap + the `environ` global }
procedure _start;
{ The static TLS template, captured from PT_TLS at startup so each spawned thread
can build its own TLS block (runtime.thread.static.freebsd uses these via
thr_new's tls_base parameter). Zero TlsMemSz means the program has no
thread-local storage. }
var
GTlsInitAddr: Pointer; { .tdata init image (= PT_TLS p_vaddr) }
GTlsFileSz: Int64; { bytes to copy from the init image }
GTlsMemSz: Int64; { total TLS size (.tdata + .tbss) }
GTlsAlign: Int64; { PT_TLS alignment }
{ Build a fresh TLS block for a new thread and return its thread pointer (the
value thr_new installs as the new thread's %fs base via tls_base). Layout
matches _start's SetupTLS: aligned TLS data followed by the TCB self-pointer.
Returns nil when the program has no TLS. }
function BuildThreadTLS: Pointer;
{ Unmap a TLS block created by BuildThreadTLS, given the thread pointer it
returned. Used to reclaim the block when thread creation fails after the TLS
was built (the offset from TP back to the mmap base is the same alignment math
BuildThreadTLS used, kept here so both sides agree). }
procedure FreeThreadTLS(ATp: Pointer);
{ The total size of a per-thread TLS block (aligned memsz + the TCB slot), which
thr_new wants as tls_size. Returns 0 when the program has no TLS. }
function ThreadTLSSize: Int64;
implementation
type
PPointer = ^Pointer;
PInt64 = ^Int64;
const
AMD64_SET_FSBASE = 129; { sysarch op — install the %fs base (verified vs
FreeBSD 14 x86/include/sysarch.h) }
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
AT_NULL = 0;
AT_PHDR = 3;
AT_PHENT = 4;
AT_PHNUM = 5;
PT_TLS = 7;
{ ELF64 Phdr field offsets. }
PH_TYPE = 0; { p_type (u32) }
PH_OFFSET = 8; { p_offset (u64) - file offset; == vaddr-base in our images }
PH_VADDR = 16; { p_vaddr (u64) }
PH_FILESZ = 32; { p_filesz (u64) }
PH_MEMSZ = 40; { p_memsz (u64) }
PH_ALIGN = 48; { p_align (u64) }
{ Round X up to the next multiple of A (A a power of two, >= 1). }
function AlignUp(X, A: Int64): Int64;
begin
if A < 1 then A := 1;
Result := (X + A - 1) and (not (A - 1));
end;
{ Install the %fs base to Tp. FreeBSD: sysarch(AMD64_SET_FSBASE, &Tp) — the
syscall takes the ADDRESS of the base value, not the value. }
procedure SetFsBase(Tp: Pointer);
var
Base: Pointer;
begin
Base := Tp;
sysarch(AMD64_SET_FSBASE, @Base);
end;
{ Walk the auxv for PT_TLS via AT_PHDR/AT_PHENT/AT_PHNUM, then build the static
TLS block and set the thread pointer. Auxv is an array of (Int64 tag, Int64
val) pairs terminated by AT_NULL. No-op when the program has no TLS. }
procedure SetupTLS(Auxv: Pointer);
var
P: PInt64;
PhdrAddr, PhEnt, PhNum: Int64;
I, Tag, Val: Int64;
Ph: PChar;
TlsVaddr, TlsFileSz, TlsMemSz, TlsAlign: Int64;
PType: ^Integer;
Block, Tp: Pointer;
BlockSize: Int64;
J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
PhdrAddr := 0; PhEnt := 56; PhNum := 0;
P := PInt64(Auxv);
while True do
begin
Tag := P^;
P := PInt64(Pointer(PChar(P) + 8));
Val := P^;
P := PInt64(Pointer(PChar(P) + 8));
if Tag = AT_NULL then Break;
if Tag = AT_PHDR then PhdrAddr := Val;
if Tag = AT_PHENT then PhEnt := Val;
if Tag = AT_PHNUM then PhNum := Val;
end;
if PhdrAddr = 0 then Exit;
{ Find PT_TLS among the program headers. }
TlsVaddr := 0; TlsFileSz := 0; TlsMemSz := 0; TlsAlign := 8;
I := 0;
while I < PhNum do
begin
Ph := PChar(Pointer(PhdrAddr + I * PhEnt));
PType := Pointer(Ph + PH_TYPE);
if PType^ = PT_TLS then
begin
TlsVaddr := PInt64(Pointer(Ph + PH_VADDR))^;
TlsFileSz := PInt64(Pointer(Ph + PH_FILESZ))^;
TlsMemSz := PInt64(Pointer(Ph + PH_MEMSZ))^;
TlsAlign := PInt64(Pointer(Ph + PH_ALIGN))^;
Break;
end;
I := I + 1;
end;
if TlsMemSz = 0 then Exit;
{ Stash the template so BuildThreadTLS can reproduce this block per thread. }
GTlsInitAddr := Pointer(TlsVaddr);
GTlsFileSz := TlsFileSz;
GTlsMemSz := TlsMemSz;
GTlsAlign := TlsAlign;
{ Allocate block = aligned(memsz) + 16 (TCB self-pointer + slack). mmap
zero-fills. }
BlockSize := AlignUp(TlsMemSz, TlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
{ Copy the .tdata init image to the start of the block; .tbss stays zero. }
Src := PChar(Pointer(TlsVaddr));
Dst := PChar(Block);
J := 0;
while J < TlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
{ Thread pointer sits just past the TLS data (variant II); store the TCB
self-pointer at *tp and set %fs. }
Tp := Pointer(PChar(Block) + AlignUp(TlsMemSz, TlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
SetFsBase(Tp);
end;
{ Build a per-thread TLS block from the template captured at startup and return
its thread pointer. Mirrors SetupTLS's block construction (variant II: TLS
data, then the TCB self-pointer at the thread pointer). On FreeBSD the caller
installs the returned TP as the new thread's %fs base via thr_new's tls_base. }
function BuildThreadTLS: Pointer;
var
Block, Tp: Pointer;
BlockSize, J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
Result := nil;
if GTlsMemSz = 0 then Exit;
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
Src := PChar(GTlsInitAddr);
Dst := PChar(Block);
J := 0;
while J < GTlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
Tp := Pointer(PChar(Block) + AlignUp(GTlsMemSz, GTlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
Result := Tp;
end;
procedure FreeThreadTLS(ATp: Pointer);
var
Block: Pointer;
BlockSize: Int64;
begin
if (ATp = nil) or (GTlsMemSz = 0) then Exit;
Block := Pointer(PChar(ATp) - AlignUp(GTlsMemSz, GTlsAlign));
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
munmap(Block, BlockSize);
end;
function ThreadTLSSize: Int64;
begin
if GTlsMemSz = 0 then
Result := 0
else
Result := AlignUp(GTlsMemSz, GTlsAlign) + 16;
end;
{ Call the program's `main(argc, argv)` (emitted by the backend) and return its
result. The asm thunk tail-jumps to the bare `main` symbol; argc/argv are
already in %edi/%rsi (SysV), exactly what main expects. }
@ -54,7 +259,8 @@ end;
procedure _BlaiseStartC(SP: Pointer);
var
Argc: Int64;
Argv, Envp: Pointer;
Argv, Envp, Auxv: Pointer;
I: Int64;
Ret: Integer;
begin
Argc := PInt64(SP)^;
@ -62,6 +268,14 @@ begin
{ envp = &argv[argc+1] }
Envp := Pointer(PChar(Argv) + (Argc + 1) * 8);
environ := Envp;
{ auxv follows envp's NULL terminator. }
Auxv := Envp;
I := 0;
while PPointer(Pointer(PChar(Auxv) + I * 8))^ <> nil do
I := I + 1;
Auxv := Pointer(PChar(Auxv) + (I + 1) * 8);
SetupTLS(Auxv);
Ret := MainTrampoline(Integer(Argc), Argv);
_exit(Ret);

78
compiler/src/main/pascal/runtime.syscall.freebsd.pas
View file

@ -111,6 +111,32 @@ function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
wrapper in the posix layer adapts that to libc's buffer-pointer contract. }
function sys_getcwd(Buf: PChar; Size: Int64): Int64;
{ Threads + TLS (Step 4c) — the FreeBSD primitives runtime.thread.static.freebsd
and runtime.start.static.freebsd build on. These have no Linux equivalents
(Linux uses clone/futex/arch_prctl); the numbers are FreeBSD-specific. }
{ sysarch(op, parms) — SYS 165. The FreeBSD way to set the %fs base for TLS:
op = AMD64_SET_FSBASE (129), parms = a POINTER to the base value (NOT the value
itself). Returns 0 on success or -errno (CF-translated). }
function sysarch(Op: Integer; Parms: Pointer): Integer;
{ _umtx_op(obj, op, val, uaddr, uaddr2) — SYS 454. The FreeBSD futex analogue.
op = UMTX_OP_WAIT_UINT_PRIVATE (15) blocks while obj^ = val (returns at once if
obj^ <> val, like futex); op = UMTX_OP_WAKE_PRIVATE (16) wakes up to val waiters
on obj. 5-arg syscall: arg4 (uaddr) arrives in %rcx -> moved to %r10. }
function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
{ thr_new(param, param_size) — SYS 455. Creates a new thread from a filled-in
`struct thr_param` (param_size = sizeof = 104 on amd64). The FreeBSD analogue
of clone(2). Returns 0 on success or -errno. }
function thr_new(Param: Pointer; ParamSize: Integer): Integer;
{ thr_exit(state) — SYS 431. Terminates JUST the calling thread (NOT the whole
process — that is exit(2)/SYS_exit). If state is non-nil the kernel writes 1
there and _umtx_op-wakes it; we clear/wake the join word ourselves and pass nil.
Never returns. }
procedure thr_exit(State: Pointer);
{ _exit(2) — SYS_exit = 1. Terminates the process; never returns. The
unit-level routine name `_exit` already emits the unmangled `_exit` symbol that
satisfies posix's `external name '_exit'`. }
@ -157,6 +183,10 @@ const
SYS_fstatat = 552; { ino64 (legacy freebsd11_fstatat = 493) }
SYS_pipe2 = 542; { pipe(2) legacy 42 deprecated }
SYS_execve = 59;
SYS_sysarch = 165; { %fs-base setup for TLS (AMD64_SET_FSBASE) }
SYS_thr_exit = 431; { terminate ONE thread (NOT exit(2)) }
SYS_umtx_op = 454; { the FreeBSD futex analogue }
SYS_thr_new = 455; { the FreeBSD clone(2) analogue }
AT_FDCWD = -100; { dirfd for path-relative *at() syscalls at cwd }
{ The asm bodies use literal immediates (the assembler needs a literal, not a
symbol); the const block above documents the number-to-name mapping. }
@ -474,6 +504,54 @@ asm
ret
end;
{ sysarch(op, parms) — 2 args, both in %rdi/%rsi already; SYS 165. Used with
AMD64_SET_FSBASE to set the %fs base to the thread pointer. }
function sysarch(Op: Integer; Parms: Pointer): Integer;
assembler; nostackframe;
asm
movq $165, %rax { SYS_sysarch }
syscall
jae .Lok_sysarch
negq %rax
.Lok_sysarch:
ret
end;
{ _umtx_op(obj, op, val, uaddr, uaddr2) — 5 args; arg4 (uaddr) arrives in %rcx
(C ABI) but the kernel wants it in %r10. Move it before the syscall. SYS 454. }
function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $454, %rax { SYS__umtx_op }
syscall
jae .Lok_umtx
negq %rax
.Lok_umtx:
ret
end;
{ thr_new(param, param_size) — 2 args, both in %rdi/%rsi already; SYS 455. }
function thr_new(Param: Pointer; ParamSize: Integer): Integer;
assembler; nostackframe;
asm
movq $455, %rax { SYS_thr_new }
syscall
jae .Lok_thr_new
negq %rax
.Lok_thr_new:
ret
end;
{ thr_exit(state) — SYS 431. Terminates JUST this thread; never returns, so no
CF translation is needed. State arrives in %rdi (nil in our use). }
procedure thr_exit(State: Pointer); assembler; nostackframe;
asm
movq $431, %rax { SYS_thr_exit }
syscall
ret
end;
{ _exit(code) — SYS_exit = 1. Terminates the process; never returns, so no
CF translation is needed. }
procedure _exit(Code: Integer); assembler; nostackframe;

312
compiler/src/main/pascal/runtime.thread.static.freebsd.pas Normal file
View file

@ -0,0 +1,312 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit runtime.thread.static.freebsd;
// Real POSIX threads for the FreeBSD --static (libc-free) build, implemented
// directly on the thr_new(2) and _umtx_op(2) syscalls
// (docs/freebsd-x86_64-backend-design.adoc, Step 4c). The FreeBSD sibling of
// runtime.thread.static.linux — the threads leaf that lets a static FreeBSD
// binary spawn worker threads (the compiler's TCompileWorker = class(TThread)).
//
// DEFINES the bare pthread_* names that runtime.weak, runtime.thread and
// classes.pas import via `external name`. The FreeBSD RTL composition links
// this unit (the link-time swap) in place of the Linux thread leaf / libc.
//
// Mutex: TARGET-INVARIANT — a 3-state futex mutex (Drepper, "Futexes Are
// Tricky"), copied verbatim from the Linux unit. The caller's mutex buffer is
// reused as the wait word (first Integer): 0 = unlocked, 1 = locked (no
// waiters), 2 = locked (waiters present). ONLY the kernel wait/wake primitive
// differs: Linux futex(WAIT/WAKE) -> FreeBSD _umtx_op(WAIT_UINT_PRIVATE=15 /
// WAKE_PRIVATE=16). WAIT_UINT returns at once if *word <> val (like futex), so
// the loop structure is identical.
//
// Thread: thr_new(2) with a filled `struct thr_param` (amd64 sizeof = 104). Each
// thread gets a fresh mmap'd stack + its own variant-II TLS block (built from
// the startup template; installed as the new thread's %fs base via thr_param's
// tls_base) so threadvar access (exception frames, the allocator) is per-thread.
//
// JOIN — the key FreeBSD difference from Linux. thr_new provides NO
// CLONE_CHILD_CLEARTID-style "clear-and-wake the tid word on exit"; child_tid is
// only written ONCE, on create, and never cleared on exit. So we use a dedicated
// JOIN word in the control block: the child's exit trampoline sets JoinWord = 1
// and _umtx_op-WAKEs it as its LAST act before thr_exit; pthread_join
// _umtx_op-WAITs on it while it reads 0. thr_exit (SYS 431) terminates JUST the
// thread — NOT exit(2)/SYS_exit, which would kill the whole process.
//
// Known limitation (same as the Linux leaf): a joined thread's TLS block is not
// unmapped — freeing it from the exiting thread is unsafe (the thread runs on it
// until thr_exit) and the join side cannot know its address. A small bounded
// per-thread leak, acceptable for the finite worker pools the compiler spawns.
interface
uses
runtime.syscall.freebsd, { mmap, _umtx_op, thr_new, thr_exit numbers }
runtime.start.static.freebsd; { BuildThreadTLS - the per-thread TLS template }
{ Mutex - the buffer's first Integer is the wait word. }
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
function pthread_mutex_lock(Mutex: Pointer): Integer;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
{ Thread create / join. *Thread receives an opaque handle (a control-block
pointer); pthread_join consumes it. }
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
implementation
type
PInteger = ^Integer;
PInt64 = ^Int64;
const
{ Mutex wait-word states. }
MX_UNLOCKED = 0;
MX_LOCKED = 1;
MX_CONTENDED = 2;
{ _umtx_op operations (FreeBSD 14 sys/sys/umtx.h; verified). }
UMTX_OP_WAIT_UINT_PRIVATE = 15; { block while *obj = val }
UMTX_OP_WAKE_PRIVATE = 16; { wake up to `val` waiters on obj }
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
STACK_SIZE = 1024 * 1024; { 1 MiB per worker thread }
{ struct thr_param amd64 field offsets (FreeBSD 14 sys/sys/thr.h; verified). }
TP_START_FUNC = 0; { void (*)(void*) }
TP_ARG = 8; { void* }
TP_STACK_BASE = 16; { char* }
TP_STACK_SIZE = 24; { size_t }
TP_TLS_BASE = 32; { char* }
TP_TLS_SIZE = 40; { size_t }
TP_CHILD_TID = 48; { long* }
TP_PARENT_TID = 56; { long* }
TP_FLAGS = 64; { int (+ 4 bytes pad) }
TP_RTP = 72; { struct rtprio* }
TP_SPARE0 = 80; { void*[3] -> 80,88,96 }
THR_PARAM_SIZE = 104; { sizeof(struct thr_param) on amd64 }
{ The per-thread control block lives at the base of the mmap'd region.
StartRoutine/Arg are the real entry the trampoline calls; JoinWord is the
_umtx_op join word (child sets 1 + WAKEs on exit, parent WAITs while it reads 0);
TidWord is thr_new's child_tid (LONG* = 8 bytes on FreeBSD, so Int64 — the
kernel writes the 8-byte TID here on create; unlike Linux it is NOT cleared on
exit, hence the separate JoinWord). MapBase/MapSize record the region for
munmap after join. }
type
PThreadCB = ^TThreadCB;
TThreadCB = record
StartRoutine: Pointer;
Arg: Pointer;
JoinWord: Integer;
Pad: Integer;
TidWord: Int64;
MapBase: Pointer;
MapSize: Int64;
end;
{ ------------------------------------------------------------------ }
{ Mutex - 3-state futex (TARGET-INVARIANT; copied from the Linux leaf) }
{ ------------------------------------------------------------------ }
{ Atomic compare-and-swap on an Integer: if Ptr^ = Expected set it to NewVal;
returns the value that was in Ptr^ before the attempt. }
function CAS(Ptr: Pointer; Expected, NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax { %eax = Expected (cmpxchg compares against %eax) }
lock cmpxchgl %edx, (%rdi)
ret
end;
{ Atomic exchange: store NewVal into Ptr^, return the previous value. }
function Xchg(Ptr: Pointer; NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax
xchgl %eax, (%rdi)
ret
end;
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
var
P: PInteger;
begin
P := PInteger(Mutex);
P^ := MX_UNLOCKED;
Result := 0;
end;
function pthread_mutex_lock(Mutex: Pointer): Integer;
var
C: Integer;
begin
{ Fast path: uncontended acquire. }
C := CAS(Mutex, MX_UNLOCKED, MX_LOCKED);
if C <> MX_UNLOCKED then
begin
{ Contended. Mark the lock contended and sleep until it is free. }
if C <> MX_CONTENDED then
C := Xchg(Mutex, MX_CONTENDED);
while C <> MX_UNLOCKED do
begin
{ WAIT_UINT_PRIVATE blocks while *Mutex = MX_CONTENDED (returns at once if
it already changed) — the FreeBSD analogue of FUTEX_WAIT. }
_umtx_op(Mutex, UMTX_OP_WAIT_UINT_PRIVATE, MX_CONTENDED, nil, nil);
C := Xchg(Mutex, MX_CONTENDED);
end;
end;
Result := 0;
end;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
begin
{ If there were waiters (state 2), wake one after releasing. }
if Xchg(Mutex, MX_UNLOCKED) = MX_CONTENDED then
_umtx_op(Mutex, UMTX_OP_WAKE_PRIVATE, 1, nil, nil);
Result := 0;
end;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
begin
Result := 0;
end;
{ ------------------------------------------------------------------ }
{ Thread create / join - thr_new(2) + _umtx_op(2) }
{ ------------------------------------------------------------------ }
{ Call Entry(Arg) — a raw indirect call so the trampoline can invoke the
caller-supplied StartRoutine held only as a Pointer. Entry arrives in %rdi,
Arg in %rsi; shuffle Arg to %rdi and call Entry. }
procedure CallEntry(Entry, Arg: Pointer); assembler; nostackframe;
asm
movq %rdi, %r11 { Entry }
movq %rsi, %rdi { Arg -> first arg }
call *%r11 { Entry(Arg) }
ret
end;
{ The thread's entry point (thr_param.start_func). The kernel starts the new
thread here with %rdi = thr_param.arg (our control-block pointer), on the fresh
stack, with the thread's own %fs already installed (tls_base). We call the real
StartRoutine(Arg), then set JoinWord = 1 and _umtx_op-WAKE it so pthread_join
unblocks, then thr_exit(nil) to terminate JUST this thread. }
procedure _thr_trampoline(CBPtr: Pointer);
var
CB: PThreadCB;
Entry: Pointer;
begin
CB := PThreadCB(CBPtr);
Entry := CB^.StartRoutine;
CallEntry(Entry, CB^.Arg);
{ Signal completion to any joiner, then terminate this thread only. }
CB^.JoinWord := 1;
_umtx_op(@CB^.JoinWord, UMTX_OP_WAKE_PRIVATE, 1, nil, nil);
thr_exit(nil);
end;
{ Store an 8-byte value at Base + Offset (used to fill struct thr_param). }
procedure PokeQ(Base: Pointer; Offset: Integer; Value: Int64);
var
Slot: PInt64;
begin
Slot := PInt64(Pointer(PChar(Base) + Offset));
Slot^ := Value;
end;
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
var
Region: Pointer;
CB: PThreadCB;
StackTop: Pointer;
Tls: Pointer;
Param: array[0..THR_PARAM_SIZE - 1] of Byte;
ParamP: Pointer;
R: Integer;
HandleSlot: PInt64;
begin
{ One mapping holds the control block (at the base) and the thread stack
(above it). mmap zero-fills, so JoinWord starts at 0. }
Region := mmap(nil, STACK_SIZE, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Region) < 0 then
begin
Result := 11; { EAGAIN }
Exit;
end;
CB := PThreadCB(Region);
CB^.StartRoutine := StartRoutine;
CB^.Arg := Arg;
CB^.JoinWord := 0;
CB^.TidWord := 0;
CB^.MapBase := Region;
CB^.MapSize := STACK_SIZE;
{ Stack grows down from the top of the region; keep it 16-byte aligned. }
StackTop := Pointer(PChar(Region) + STACK_SIZE);
StackTop := Pointer(Int64(StackTop) and (not Int64(15)));
{ Each thread needs its own TLS block for threadvar access. }
Tls := BuildThreadTLS();
{ Fill struct thr_param on the stack (zero-init first so flags/rtp/spare = 0). }
ParamP := @Param[0];
PokeQ(ParamP, TP_START_FUNC, Int64(Pointer(@_thr_trampoline)));
PokeQ(ParamP, TP_ARG, Int64(CB));
PokeQ(ParamP, TP_STACK_BASE, Int64(Region));
{ stack_size = distance from the region base to the aligned stack top. }
PokeQ(ParamP, TP_STACK_SIZE, Int64(StackTop) - Int64(Region));
PokeQ(ParamP, TP_TLS_BASE, Int64(Tls));
PokeQ(ParamP, TP_TLS_SIZE, ThreadTLSSize());
PokeQ(ParamP, TP_CHILD_TID, Int64(@CB^.TidWord));
PokeQ(ParamP, TP_PARENT_TID, Int64(@CB^.TidWord));
PokeQ(ParamP, TP_FLAGS, 0); { flags = 0 (+ pad) }
PokeQ(ParamP, TP_RTP, 0); { rtp = nil -> default scheduling }
PokeQ(ParamP, TP_SPARE0, 0);
PokeQ(ParamP, TP_SPARE0 + 8, 0);
PokeQ(ParamP, TP_SPARE0 + 16, 0);
R := thr_new(ParamP, THR_PARAM_SIZE);
if R < 0 then
begin
munmap(Region, STACK_SIZE);
FreeThreadTLS(Tls); { reclaim the per-thread TLS block too }
Result := 11; { EAGAIN }
Exit;
end;
{ Hand the caller the control-block pointer as the opaque thread handle. }
HandleSlot := PInt64(Thread);
HandleSlot^ := Int64(CB);
Result := 0;
end;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
var
CB: PThreadCB;
W: Integer;
begin
CB := PThreadCB(Pointer(Thread));
{ The child sets JoinWord = 1 and _umtx_op-WAKEs it as its last act before
thr_exit. WAIT while it still reads 0. WAIT_UINT returns at once if the word
already changed, so no wake can be missed. }
W := CB^.JoinWord;
while W = 0 do
begin
_umtx_op(@CB^.JoinWord, UMTX_OP_WAIT_UINT_PRIVATE, 0, nil, nil);
W := CB^.JoinWord;
end;
munmap(CB^.MapBase, CB^.MapSize);
Result := 0;
end;
end.

81
compiler/src/test/pascal/cp.test.linker.pas
View file

@ -97,6 +97,11 @@ type
MAP_FAILED (-1) so runtime.mem takes its alloc-copy-free grow fallback (no
in-place remap syscall on FreeBSD). Standalone byte/symbol shape. }
procedure TestLink_FreeBSDSyscallLeaf_GetrandomAndMremapStub;
{ Step 4c: the FreeBSD threads/TLS leaf — thr_new (455), _umtx_op (454) and
thr_exit (431) link under the FreeBSD target with their FreeBSD syscall
numbers present in the linked .text, and NOT Linux's clone (56) / futex
(202). Standalone byte/symbol shape. }
procedure TestLink_FreeBSDThreadLeaf_SyscallNumbers;
end;
TDynLinkerTests = class(TTestCase)
@ -1270,6 +1275,82 @@ begin
AssertTrue('mremap stub returns -1 (MAP_FAILED)', Pos(MovRaxImm4b(-1), Bytes) >= 0);
end;
procedure TLinkerE2ETests.TestLink_FreeBSDThreadLeaf_SyscallNumbers;
const
{ Mirrors the runtime.syscall.freebsd threads/TLS leaf bodies: thr_new (455),
_umtx_op (454, with its arg4 %rcx->%r10 shuffle) and thr_exit (431). These
are the FreeBSD analogues of Linux's clone (56) / futex (202) / exit (60);
the numbers MUST be FreeBSD's, not Linux's. A leading _start keeps the
linker's entry resolvable. }
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' callq thr_new' + LineEnding +
' callq _umtx_op' + LineEnding +
' callq thr_exit' + LineEnding +
' xorl %edi, %edi' + LineEnding +
' movq $1, %rax' + LineEnding + { SYS_exit }
' syscall' + LineEnding +
' hlt' + LineEnding +
'.globl thr_new' + LineEnding +
'thr_new:' + LineEnding +
' movq $455, %rax' + LineEnding + { SYS_thr_new }
' syscall' + LineEnding +
' jae .Lok_thr_new' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_thr_new:' + LineEnding +
' ret' + LineEnding +
'.globl _umtx_op' + LineEnding +
'_umtx_op:' + LineEnding +
' movq %rcx, %r10' + LineEnding +
' movq $454, %rax' + LineEnding + { SYS__umtx_op }
' syscall' + LineEnding +
' jae .Lok_umtx' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_umtx:' + LineEnding +
' ret' + LineEnding +
'.globl thr_exit' + LineEnding +
'thr_exit:' + LineEnding +
' movq $431, %rax' + LineEnding + { SYS_thr_exit }
' syscall' + LineEnding +
' ret' + LineEnding;
{ Encoded `movq $imm32, %rax` = 48 C7 C0 <imm32-LE>. }
function MovRaxImm4c(AImm: Integer): string;
begin
Result := Chr($48) + Chr($C7) + Chr($C0) +
Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
end;
var
Lk: TLinker;
Obj: TElfObjectFile;
Bytes: string;
begin
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbthr.o');
Lk.AddOwnedObject(Obj);
Bytes := Lk.LinkToBytes('_start');
{ The bare thread-primitive symbols must be DEFINED (non-zero address). }
AssertTrue('thr_new defined', Lk.AddrOfSymbol('thr_new') > 0);
AssertTrue('_umtx_op defined', Lk.AddrOfSymbol('_umtx_op') > 0);
AssertTrue('thr_exit defined', Lk.AddrOfSymbol('thr_exit') > 0);
finally
Lk.Free();
end;
{ FreeBSD thread syscall NUMBERS present in the linked .text. }
AssertTrue('SYS_thr_new=455 movq imm present', Pos(MovRaxImm4c(455), Bytes) >= 0);
AssertTrue('SYS__umtx_op=454 movq imm present', Pos(MovRaxImm4c(454), Bytes) >= 0);
AssertTrue('SYS_thr_exit=431 movq imm present', Pos(MovRaxImm4c(431), Bytes) >= 0);
{ NOT Linux's clone (56) / futex (202) — those numbers must be absent. }
AssertTrue('Linux SYS_clone=56 NOT present', Pos(MovRaxImm4c(56), Bytes) < 0);
AssertTrue('Linux SYS_futex=202 NOT present', Pos(MovRaxImm4c(202), Bytes) < 0);
{ _umtx_op's arg4 shuffle: movq %rcx, %r10 (49 89 CA). }
AssertTrue('movq %rcx,%r10 (_umtx_op arg4) present',
Pos(Chr($49) + Chr($89) + Chr($CA), Bytes) >= 0);
end;
{ ---- TDynLinkerTests ---- }
function TDynLinkerTests.ProjectRoot: string;