rewrite run-liminix-vm as a fennel program

the effect of shell quoting/word splitting rules was reaching
completely unreasonable, insofar as I was unable to reason about it
pull/2/head
Daniel Barlow 2023-12-03 22:51:39 +00:00
parent cb6ebbdc60
commit 98d3336926
5 changed files with 138 additions and 91 deletions

View File

@ -54,7 +54,7 @@ in
then "${pkgs.stdenv.cc.targetPrefix}objcopy -O binary -R .comment -S ${kernel} $out"
else "cp ${kernel} $out");
phram_address = lib.toHexString (config.hardware.ram.startAddress + 256 * 1024 * 1024);
in pkgs.runCommandCC "vmroot" {} ''
in pkgs.runCommand "vmroot" {} ''
mkdir $out
cd $out
ln -s ${rootfs} rootfs
@ -64,7 +64,7 @@ in
echo ${cmdline} > commandline
cat > run.sh << EOF
#!${pkgs.runtimeShell}
CMDLINE=${cmdline} PHRAM_ADDRESS=0x${phram_address} ${pkgs.pkgsBuildBuild.run-liminix-vm}/bin/run-liminix-vm --arch ${pkgs.stdenv.hostPlatform.qemuArch} \$* ${makeBootableImage} ${config.system.outputs.rootfs}
${pkgs.pkgsBuildBuild.run-liminix-vm}/bin/run-liminix-vm --command-line ${builtins.toJSON cmdline} --arch ${pkgs.stdenv.hostPlatform.qemuArch} --phram-address 0x${phram_address} \$* ${makeBootableImage} ${config.system.outputs.rootfs}
EOF
chmod +x run.sh
'';

View File

@ -1,19 +1,23 @@
{
qemu
, socat
, writeShellScriptBin
, symlinkJoin
, writeShellScript
, writeFennel
, runCommand
, lib
, lua
, pkgsBuildBuild
}: let
run-liminix-vm = writeShellScriptBin "run-liminix-vm" ''
export PATH="${lib.makeBinPath [qemu]}:$PATH"
${builtins.readFile ./run-liminix-vm.sh}
'';
connect = writeShellScriptBin "connect-vm" ''
run-liminix-vm = pkgsBuildBuild.writeFennel "run-liminix-vm" {
packages = [ qemu lua.pkgs.luaposix lua.pkgs.fennel ];
} ./run-liminix-vm.fnl;
connect = writeShellScript "connect-vm" ''
export PATH="${lib.makeBinPath [socat]}:$PATH"
socat -,raw,echo=0,icanon=0,isig=0,icrnl=0,escape=0x0f unix-connect:$1
'';
in symlinkJoin {
name = "run-liminix-vm";
paths = [ run-liminix-vm connect ];
}
in runCommand "vm" {} ''
mkdir -p $out/bin
cd $out/bin
ln -s ${connect} ./connect-vm
ln -s ${run-liminix-vm} ./run-liminix-vm
''

View File

@ -0,0 +1,120 @@
(local { : fork : execp : unlink } (require :posix.unistd))
(local { : wait } (require :posix.sys.wait))
(local { : mkstemp : setenv } (require :posix.stdlib))
(local { : fdopen } (require :posix.stdio))
(fn pad-file [name kb chr]
(let [(fd out) (mkstemp "run-vm-XXXXXXX")
pad-string (string.rep (or chr "\0") 1024)]
(with-open [f (fdopen fd :w)]
(for [i 1 kb] (f:write pad-string))
(f:seek :set 0)
(with-open [input (assert (io.open name :rb))]
(f:write (input:read "*a")))
(f:seek :end 0))
out))
(fn spawn [command args]
(match (fork)
(nil msg) (error (.. "couldn't fork: " msg))
0 (execp command args)
pid (wait pid)))
(fn appendm [t2 t1]
(table.move t1 1 (# t1) (+ 1 (# t2)) t2)
t2)
(fn merge [table1 table2]
(collect [k v (pairs table2) &into table1]
k v))
(fn assoc [tbl k v]
(tset tbl k v)
tbl)
(fn parse-args [args]
(match args
["--background" dir & rest] (assoc (parse-args rest) :background dir)
["--u-boot" bin & rest]
(assoc (parse-args rest) :u-boot (pad-file bin (* 4 1024) "\xff"))
["--arch" arch & rest] (assoc (parse-args rest) :arch arch)
["--phram-address" addr & rest] (assoc (parse-args rest) :phram-address addr)
["--lan" spec & rest] (assoc (parse-args rest) :lan spec)
["--command-line" cmd & rest] (assoc (parse-args rest) :command-line cmd)
[kernel rootfsimg]
{ :kernel kernel :rootfs (pad-file rootfsimg (* 16 1024)) }
))
(local options
(assert
(merge { :arch "mips" } (parse-args arg))
(.. "Usage: " (. arg 0) " blah bah")))
(fn background [dir]
(let [pid (.. dir "/pid")
sock (.. dir "/console")
monitor (.. dir "/monitor")]
["--daemonize"
"--pidfile" pid
"-serial" (.. "unix:" sock ",server,nowait")
"-monitor" (.. "unix:" monitor ",server,nowait")]))
(fn access-net []
[
"-netdev" "socket,id=access,mcast=230.0.0.1:1234,localaddr=127.0.0.1"
"-device" "virtio-net,disable-legacy=on,disable-modern=off,netdev=access,mac=ba:ad:1d:ea:21:02"
])
(fn local-net [override]
[
"-netdev" (.. (or override "socket,mcast=230.0.0.1:1235,localaddr=127.0.0.1")
",id=lan")
"-device" "virtio-net,disable-legacy=on,disable-modern=off,netdev=lan,mac=ba:ad:1d:ea:21:01"
])
(fn bootable [cmdline uboot]
(if uboot
(let [pflash (os.tmpname)
ffs (string.rep "\xff" 1024)]
(with-open [f (assert (io.open pflash :wb))]
(for [i 1 (* 4 1024)] (f:write ffs))
(f:seek :set 0)
(with-open [uboot-bin (assert (io.open uboot :rb))]
(f:write (uboot-bin:read "*a")))
(f:seek :end 0))
["-drive" (.. "if=pflash,format=raw,file=\"" pflash "\"")])
(let [cmdline (.. cmdline " liminix mtdparts=phram0:16M(rootfs) phram.phram=phram0," options.phram-address ",16Mi,65536 root=/dev/mtdblock0")]
["-kernel" options.kernel "-append" cmdline])))
(local bin {
:mips ["qemu-system-mips" "-M" "malta"]
:aarch64 ["qemu-system-aarch64" "-M" "virt"
"-semihosting" "-cpu" "cortex-a72"]
:arm ["qemu-system-arm" "-M" "virt,highmem=off"
"-cpu" "cortex-a15"]
})
(local exec-args
(-> []
(appendm (. bin options.arch))
(appendm ["-m" "272"
"-echr" "16"
"-device"
(.. "loader,file=" options.rootfs ",addr=" options.phram-address)
])
(appendm
(if options.background
(background options.background)
["-serial" "mon:stdio"]))
(appendm (bootable (or options.command-line "") options.u-boot))
(appendm (access-net))
(appendm (local-net options.lan))
(appendm ["-display" "none"])))
(match exec-args
[cmd & params] (print (spawn cmd params)))
(if options.rootfs (unlink options.rootfs))
(if options.u-boot (unlink options.u-boot))

View File

@ -1,78 +0,0 @@
#!/usr/bin/env bash
cleanup(){
test -n "$rootfs" && test -f $rootfs && rm $rootfs
}
trap 'exit 1' INT HUP QUIT TERM ALRM USR1
trap 'cleanup' EXIT
usage(){
echo "usage: $(basename $0) [--background /path/to/state_directory] kernel rootimg [initramfs]"
echo -e "\nWithout --background, use C-p c (not C-a c) to switch to the monitor"
exit 1
}
arch="mips"
if test "$1" = "--arch" ; then
arch=$2
shift;shift
fi
if test "$1" = "--background" ; then
statedir=$2
if test -z "$statedir" || ! test -d $statedir ; then
usage
fi
pid="${statedir}/pid"
socket="${statedir}/console"
monitor="${statedir}/monitor"
echo "running in background, socket is $socket, pid $pid"
flags="--daemonize --pidfile $pid -serial unix:$socket,server,nowait -monitor unix:$monitor,server,nowait"
shift;shift
else
flags="-serial mon:stdio"
fi
test -n "$2" || usage
lan=${LAN-"socket,mcast=230.0.0.1:1235,localaddr=127.0.0.1"}
rootfs=$(mktemp run-liminix-vm-fs-XXXXXX)
dd if=/dev/zero of=$rootfs bs=1M count=16 conv=sync
dd if=$2 of=$rootfs bs=65536 conv=sync,nocreat,notrunc
if test -n "$3"; then
initramfs="-initrd $3"
fi
case "$arch" in
mips)
QEMU="qemu-system-mips -M malta"
;;
aarch64)
QEMU="qemu-system-aarch64 -M virt -semihosting -cpu cortex-a72"
;;
arm)
# https://bugs.launchpad.net/qemu/+bug/1790975
QEMU="qemu-system-arm -M virt,highmem=off -cpu cortex-a15"
;;
*)
echo "unrecognised arch $arch"
exit 1;
;;
esac
phram="mtdparts=phram0:16M(rootfs) phram.phram=phram0,${PHRAM_ADDRESS},16Mi,65536 root=/dev/mtdblock0";
set -x
$QEMU \
-m 272 \
-echr 16 \
-append "$CMDLINE liminix $phram" \
-device loader,file=$rootfs,addr=$PHRAM_ADDRESS \
${initramfs} \
-netdev socket,id=access,mcast=230.0.0.1:1234,localaddr=127.0.0.1 \
-device virtio-net,disable-legacy=on,disable-modern=off,netdev=access,mac=ba:ad:1d:ea:21:02 \
-netdev ${lan},id=lan \
-device virtio-net,disable-legacy=on,disable-modern=off,netdev=lan,mac=ba:ad:1d:ea:21:01 \
-kernel $1 -display none $flags ${QEMU_OPTIONS}

View File

@ -27,6 +27,7 @@ name :
echo "#!${lua}/bin/lua ${luaFlags}"
echo "package.path = ${lib.strings.escapeShellArg (builtins.concatStringsSep "" luapath)} .. package.path"
echo "package.cpath = ${lib.strings.escapeShellArg (builtins.concatStringsSep "" luacpath)} .. package.cpath"
echo "require('posix.stdlib').setenv('PATH',${lib.escapeShellArg (lib.makeBinPath packages)} .. \":\" .. os.getenv('PATH'))"
fennel ${if correlate then "--correlate" else ""} --compile ${source}
) > ${name}.lua
'';