changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / x.lisp

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