changeset 460: |
d7ca8ff34865 |
parent: |
68414f8bbd03
|
child: |
af486e0a40c9 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Wed, 19 Jun 2024 16:55:04 -0400 |
permissions: |
-rwxr-xr-x |
description: |
x/infra |
1 #!/usr/bin/env -S sbcl --no-sysinit --no-userinit --script 8 #-(or sbcl cl) (error "unsupported Lisp compiler") 10 (let ((quicklisp-init (or (probe-file #p"~/.stash/quicklisp/setup.lisp") 11 (probe-file #p"/usr/local/share/lisp/quicklisp/setup.lisp") 12 (probe-file #p "~/quicklisp/setup.lisp")))) 13 (when (probe-file quicklisp-init) 14 (load quicklisp-init))) 15 (require 'sb-rotate-byte) 16 (require 'sb-introspect) 22 (asdf:load-system (asdf:find-system :cl-ppcre)) 23 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/"))) 24 (asdf:load-system :std) 27 (:use :cl :std :std/named-readtables :cl-user) 28 (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path* 29 :*compression-level*)) 32 (use-package :sb-gray) 33 ;; (require 'sb-aclrepl) 34 (sb-ext:enable-debugger) 35 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!")))) 37 (defvar *lisp-path* (merge-pathnames "lisp/" *core-path*)) 38 (defvar *bin-path* (merge-pathnames "bin/" *lisp-path*)) 39 (defvar *web-path* (merge-pathnames "web/" *lisp-path*)) 40 (defvar *lib-path* (merge-pathnames "lib/" *lisp-path*)) 41 (defvar *std-path* (merge-pathnames "std/" *lisp-path*)) 42 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*)) 43 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*)) 45 (defvar *compression-level* nil) 47 (push *core-path* asdf:*central-registry*) 48 (push *lisp-path* ql:*local-project-directories*) 49 (push *lib-path* ql:*local-project-directories*) 50 (push *bin-path* ql:*local-project-directories*) 51 (push *ffi-path* ql:*local-project-directories*) 53 (ql:register-local-projects) 55 (unless (asdf:find-system :log nil) 56 (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*)))) 58 (asdf:load-system :log) 61 (unless (asdf:find-system :rocksdb nil) 62 (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*))) 63 (asdf:load-system :rocksdb)) 65 (unless (asdf:find-system :cli nil) 66 (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*)))) 68 (asdf:load-system :cli) 71 (defun done () (print :OK)) 73 (defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) 74 (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*)) 76 (defun compile-std (&optional force save) 79 (in-package :std-user) 80 (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*))) 82 (defun compile-prelude (&optional force save) 84 (asdf:compile-system :prelude :force force) 85 (asdf:load-system :prelude :force force) 86 ;; (rocksdb:load-rocksdb save) 88 (in-package :std-user) 89 (use-package :cl-user) 90 (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*))) 92 (defun compile-user (&optional force save compression (name "user.core")) 93 (asdf:compile-system :user :force force) 94 (asdf:load-system :user :force force) 97 (use-package :cl-user) 98 (sb-ext:save-lisp-and-die (merge-pathnames name *stash-path*) :compression (or compression *compression-level*)))) 101 (defun compile-tests (&optional force save) 102 (asdf:compile-system :core/tests :force force) 103 (asdf:load-system :core/tests :force force) 105 (in-package :core/tests) 106 (sb-ext:save-lisp-and-die (merge-pathnames "tests.core" *stash-path*) :compression *compression-level*))) 108 (defun compile-core (&optional force save) 109 (asdf:compile-system :core :force force) 110 (asdf:load-system :core :force force) 113 (sb-ext:save-lisp-and-die (merge-pathnames "core.core" *stash-path*) :compression *compression-level*))) 115 (defun save-foreign (name exports &rest args) 116 (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args))) 118 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude)) 119 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std)) 120 (sb-alien:define-alien-callable compile-user sb-alien:void () (compile-user)) 124 (setq *print-level* 32 126 ;; collect args from shell 127 (defvar *args* (cdr sb-ext:*posix-argv*)) 130 (help "x.lisp --- core build tool 153 (defun parse-flag (arg) 155 (if (or (characterp k) (= (length k) 1)) 156 (case (char-downcase (character k)) 160 (if (char-equal (aref arg 0) #\-) 161 (if (= (length arg) 2) ;; short 163 (if (char-equal (aref arg 1) #\-) ;; long 165 (bail "invalid flag")))))) 167 ;; (defun parse-arg (arg)) 168 (defun x-compile (args) 170 (let ((name (car args))) 172 (asdf:compile-system name :force t)) 173 (compile-prelude t nil))) 176 (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*)) 177 (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name))))) 179 (push :ssl *features*) 180 ;; (std/sys:forget-shared-objects) 183 (defun x-build (args) 185 (let ((name (car args))) 186 (ensure-directories-exist *stash-path*) 188 (std:wait-for-threads (mapcar 190 (sb-thread:make-thread 192 (sb-ext:run-program "x.lisp" (list "build" x) :wait t :output t)) 194 (list "skel" "rdb" "organ" "homer" "packy"))))) 196 (defun stash-output (name) 197 (let* ((sys (asdf:find-system name)) 199 :name (asdf/system:component-build-pathname sys) 200 :type (if (string-equal name "std") 203 (uiop:rename-file-overwriting-target 204 (merge-pathnames fasl (asdf:system-source-directory sys)) 205 (merge-pathnames fasl *stash-path*)))) 208 (let ((sys (sb-int:keywordicate (string-upcase name)))) 209 (std/sys:forget-shared-objects) 210 (asdf:load-system sys) 211 (in-package :std-user) 219 (let ((name (car args))) 220 (ensure-directories-exist *stash-path*) 222 (std:wait-for-threads (mapcar 224 (sb-thread:make-thread 226 (sb-ext:run-program "x.lisp" (list "make" x) :wait t :output t)) 228 (list "core" "user" "prelude" "core/tests" "core/bench" "core/lib" "core/ffi"))))) 232 (let ((name (car args))) 233 (ensure-directories-exist *stash-path*) 234 (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*)) 236 ("prelude" (compile-prelude t t)) 237 ("core" (compile-core t t)) 238 ("std" (compile-std t t)) 239 ("user" (compile-user t t)) 240 ("infra" (compile-user t t 22 "infra.core")) 241 ("tests" (compile-tests t t)))) 242 ;; (sb-ext:run-program "x.lisp" nil :input t :output t) 245 (asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/"))) 246 (asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/"))) 247 (asdf:load-system :log) 248 (asdf:load-system :rt) 253 (let ((name (car args))) 255 (ql:quickload (string-upcase (format nil "~A/tests" name))) 256 (rt:do-tests (string-upcase name) t)) 257 (bail "missing arg"))) 261 (let* ((name (car args)) 262 (path (merge-pathnames name *stash-path*))) 263 (unless (probe-file path) 264 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 265 (sb-ext:run-program path (cdr args) :output t)) 266 (bail "missing arg"))) 268 (defun %install (name) 269 (let ((path (merge-pathnames name *stash-path*))) 270 (unless (probe-file path) 271 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 272 (sb-ext:run-program "/bin/sudo" 273 (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/") 277 (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/")))) 279 (defun x-install (args) 282 (list "skel" "rdb" "organ" "homer" "packy")))) 284 (defun x-parse-args () 287 (println "Welcome to CORE/X") 288 (use-package :cl-user) 289 (use-package :sb-ext) 290 (use-package :std-user) 291 (sb-impl::toplevel-repl nil)) 292 (let ((cmd (pop *args*))) 294 ((equal cmd "compile") (setq *thunk* #'x-compile)) 295 ((equal cmd "build") (setq *thunk* #'x-build)) 296 ((equal cmd "run") (setq *thunk* #'x-run)) 297 ((equal cmd "test") (setq *thunk* #'x-test)) 298 ((equal cmd "save") (setq *thunk* #'x-save)) 299 ((equal cmd "make") (setq *thunk* #'x-make)) 300 ((equal cmd "install") (setq *thunk* #'x-install)) 301 (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0)))))) 305 (let ((*args* (cdr sb-ext:*posix-argv*)) 308 (log:debug! "running command" *thunk* *args*) 309 (funcall *thunk* *args*))) 311 ;; (format t "saving self to ./x~%") 312 ;; (sb-ext:save-lisp-and-die 314 ;; :toplevel #'x-init 315 ;; ;; :callable-exports '("compile_std" "compile_prelude") 318 ;; :save-runtime-options t)