changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / x.lisp

changeset 370: 9f8f4c26d379
parent: 494d3b93b29b
child: d1d64b856fae
child: 5b6e317ec568
author: Richard Westhaver <ellis@rwest.io>
date: Sun, 26 May 2024 15:41:14 -0400
permissions: -rwxr-xr-x
description: set compression for binaries 
     1 #!/usr/local/bin/sbcl --script
     2 ;;; core build tool
     3 
     4 ;; 
     5 #|
     6 x.lisp
     7 |#
     8 (require 'asdf)
     9 (require 'sb-posix)
    10 (require 'sb-concurrency)
    11 
    12 #-(or sbcl cl) (error "unsupported Lisp compiler")
    13 
    14 #-quicklisp
    15 (let ((quicklisp-init "/usr/local/share/lisp/quicklisp/setup.lisp"))
    16   (when (probe-file quicklisp-init)
    17     (load quicklisp-init)))
    18 
    19 (unless (asdf:find-system :cl-ppcre nil)
    20   (ql:quickload :cl-ppcre)
    21   ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd"))
    22   )
    23 
    24 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/")))
    25 (asdf:load-system :std)
    26 
    27 (defpackage :x
    28   (:use :cl :std :std/named-readtables)
    29   (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path*
    30            :*compression-level*))
    31 
    32 (in-package :x)
    33 (require 'sb-rotate-byte)
    34 (require 'sb-introspect)
    35 (require 'sb-grovel)
    36 (require 'sb-cltl2)
    37 (require 'sb-cover)
    38 (require 'sb-sprof)
    39 (use-package :sb-gray)
    40 ;; (require 'sb-aclrepl)
    41 (sb-ext:enable-debugger)
    42 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
    43 
    44 (defvar *lisp-path* (merge-pathnames "lisp/" *core-path*))
    45 (defvar *bin-path* (merge-pathnames "bin/" *lisp-path*))
    46 (defvar *web-path* (merge-pathnames "web/" *lisp-path*))
    47 (defvar *lib-path* (merge-pathnames "lib/" *lisp-path*))
    48 (defvar *std-path* (merge-pathnames "std/" *lisp-path*))
    49 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
    50 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*))
    51 
    52 (defvar *compression-level* t)
    53 
    54 (push *core-path* asdf:*central-registry*)
    55 (push *lisp-path* ql:*local-project-directories*)
    56 (push *lib-path* ql:*local-project-directories*)
    57 (push *bin-path* ql:*local-project-directories*)
    58 (push *ffi-path* ql:*local-project-directories*)
    59 
    60 (ql:register-local-projects)
    61 
    62 (unless (asdf:find-system :log nil)
    63   (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*))))
    64 
    65 (asdf:load-system :log)
    66 (use-package :log)
    67 
    68 (unless (asdf:find-system :rocksdb nil)
    69   (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*)))
    70   (asdf:load-system :rocksdb))
    71 
    72 (unless (asdf:find-system :cli nil)
    73   (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*))))
    74 
    75 (asdf:load-system :cli)
    76 (use-package :cli)
    77 
    78 (defun done () (print :OK))
    79 
    80 (defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
    81   (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*))
    82 
    83 (defun compile-std (&optional force save)
    84   (asdf:compile-system :std :force force)
    85   (asdf:load-system :std :force force)
    86   (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*)))
    87 
    88 (defun compile-prelude (&optional force save)
    89   ;; (compile-std)
    90   (asdf:compile-system :prelude :force force)
    91   ;; (rocksdb:load-rocksdb save)
    92   (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*)))
    93 
    94 (defun save-foreign (name exports &rest args)
    95   (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
    96 
    97 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude))
    98 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
    99 
   100 (defvar *thunk* nil)
   101 
   102 (setq *print-level* 32
   103       *print-length* 64)
   104 ;; collect args from shell
   105 (defvar *args* (cdr sb-ext:*posix-argv*))
   106 (defvar *flags*
   107   '((version "0.1.0")
   108     (help "x --- core build tool
   109 x.lisp [CMD]
   110 CMDS:
   111 test
   112 compile
   113 build
   114 test
   115 run
   116 save
   117 install")))
   118 
   119 (defun getflag (k)
   120   (cadar
   121    (member
   122     (string-upcase k)
   123     *flags*
   124     :test #'string=
   125     :key #'car)))
   126 
   127 (defun bail (msg)
   128   (log::fatal! msg))
   129 
   130 (defun parse-flag (arg)
   131   (flet ((f (k)
   132            (if (or (characterp k) (= (length k) 1))
   133                (case (char-downcase (character k))
   134                  (#\v "VERSION")
   135                  (#\h "HELP"))
   136                k)))
   137     (if (char-equal (aref arg 0) #\-)
   138         (if (= (length arg) 2) ;; short
   139             (f (aref arg 1))
   140             (if (char-equal (aref arg 1) #\-) ;; long
   141                 (f (subseq arg 2))
   142                 (bail "invalid flag"))))))
   143 
   144 ;; (defun parse-arg (arg))
   145 (defun x-compile (args)
   146   (if args
   147       (let ((name (car args)))
   148         (ql:quickload name)
   149         (asdf:compile-system name :force t))
   150       (compile-prelude t nil)))
   151 
   152 (defun %build (name)
   153   (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*))
   154   (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name)))))
   155     (ql:quickload sys)
   156     (asdf:make sys)))
   157 
   158 (defun x-build (args)
   159   (if args
   160       (let ((name (car args)))
   161         (ensure-directories-exist *stash-path*)
   162         (%build name))
   163       (std:wait-for-threads (mapcar
   164                              (lambda (x)
   165                                (sb-thread:make-thread
   166                                 (lambda ()
   167                                   (sb-ext:run-program "x" (list "build" x) :wait t :output t))
   168                                 :name x))
   169                              (list "skel" "rdb" "organ" "homer" "packy")))))
   170 
   171 (defun x-save (args)
   172   (if args
   173       (let ((name (car args)))
   174         (ensure-directories-exist *stash-path*)
   175         (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
   176         (string-case (name)
   177           ("prelude" (compile-prelude t t))
   178           ("std" (compile-std t t))))
   179       ;; self save
   180       (sb-ext:run-program "x.lisp" nil :input t :output t)))
   181 
   182 (asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/")))
   183 (asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/")))
   184 (asdf:load-system :log)
   185 (asdf:load-system :rt)
   186 (ql:quickload :rt)
   187 
   188 (defun x-test (args)
   189   (if args
   190       (let ((name (car args)))
   191         (ql:quickload :rt)
   192         (ql:quickload (string-upcase (format nil "~A/tests" name)))
   193         (rt:do-tests (string-upcase name) t))
   194       (bail "missing arg")))
   195 
   196 (defun x-run (args)
   197   (if args
   198       (let* ((name (car args))
   199              (path (merge-pathnames name *stash-path*)))
   200         (unless (probe-file path)
   201           (sb-ext:run-program "x" (list "build" name) :wait t :output t))
   202         (sb-ext:run-program path (cdr args) :output t))
   203       (bail "missing arg")))
   204 
   205 (defun %install (name)
   206   (let ((path (merge-pathnames name *stash-path*)))
   207     (unless (probe-file path)
   208       (sb-ext:run-program "x" (list "build" name) :wait t :output t))
   209     (sb-ext:run-program "/bin/sudo"
   210                         (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/")
   211                         :input t
   212                         :wait t
   213                         :output t)
   214     (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/"))))
   215 
   216 (defun x-install (args)
   217   (mapc #'%install
   218         (or args
   219             (list "skel" "rdb" "organ" "homer" "packy"))))
   220 
   221 (defun x-parse-args ()
   222   (if (null *args*)
   223       (progn
   224         (println "Welcome to CORE/X")
   225         (use-package :cl-user)
   226         (use-package :sb-ext)
   227         (use-package :std-user)
   228         (sb-impl::toplevel-repl nil))
   229       (let ((cmd (pop *args*)))
   230         (cond
   231           ((equal cmd "compile") (setq *thunk* #'x-compile))
   232           ((equal cmd "build") (setq *thunk* #'x-build))
   233           ((equal cmd "run") (setq *thunk* #'x-run))
   234           ((equal cmd "test") (setq *thunk* #'x-test))
   235           ((equal cmd "save") (setq *thunk* #'x-save))
   236           ((equal cmd "install") (setq *thunk* #'x-install))
   237           (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0))))))
   238 
   239 (defun x-init ()
   240   (in-package :x)
   241   (let ((*args* (cdr sb-ext:*posix-argv*))
   242         (*log-level* :info))
   243     (x-parse-args)
   244     (log:debug! "running command" *thunk* *args*)
   245     (funcall *thunk* *args*)))
   246 
   247 (format t "saving self to ./x~%")
   248 (sb-ext:save-lisp-and-die
   249  "x"
   250  :toplevel #'x-init
   251  ;; :callable-exports '("compile_std" "compile_prelude")
   252  :purify nil
   253  :executable t
   254  :save-runtime-options t)