From 4bb2e2dee10801446f1b8bb77714410591b91d19 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 23 Apr 2024 11:09:50 -0400 Subject: [PATCH 01/37] translate: rearrange --- src/lisp/kernel/cleavir/translate.lisp | 59 ++++++++++++-------------- 1 file changed, 28 insertions(+), 31 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 61ba9c45c4..cbc591f720 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1836,28 +1836,30 @@ body-irbuilder body-block abi &key (linkage 'llvm-sys:internal-linkage)) (declare (ignore linkage)) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (body-irbuilder) - (with-catch-pad-prep - (cmp:irc-begin-block body-block) - (cmp:with-landing-pad (never-entry-landing-pad ir) - ;; Bind the arguments and the environment values - ;; appropriately. - (let ((llvm-function-info (find-llvm-function-info ir))) - (loop for arg in (llvm-sys:get-argument-list the-function) - ;; remove-if is to remove fixed closure params. - for lexical in (append (remove-if #'null (environment llvm-function-info)) - (arguments llvm-function-info)) - when lexical ; skip unused fixed - do (setf (gethash lexical *datum-values*) arg))) - ;; Branch to the start block. - (cmp:irc-br (iblock-tag (bir:start ir))) - ;; Lay out blocks. - (bir:do-iblocks (ib ir) - (layout-iblock ib abi)))))) - ;; Finish up by jumping from the entry block to the body block - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:irc-br body-block)) + (cmp:with-irbuilder (body-irbuilder) + ;; Start the iblocks - put in phis and record them in our mapping + ;; for jumps. + (bir:do-iblocks (ib ir) + (setf (gethash ib *tags*) + (cmp:irc-basic-block-create (iblock-name ib))) + (initialize-iblock-translation ib)) + (with-catch-pad-prep + (cmp:irc-begin-block body-block) + (cmp:with-landing-pad (never-entry-landing-pad ir) + ;; Bind the arguments and the environment values + ;; appropriately. + (let ((llvm-function-info (find-llvm-function-info ir))) + (loop for arg in (llvm-sys:get-argument-list the-function) + ;; remove-if is to remove fixed closure params. + for lexical in (append (remove-if #'null (environment llvm-function-info)) + (arguments llvm-function-info)) + when lexical ; skip unused fixed + do (setf (gethash lexical *datum-values*) arg))) + ;; Branch to the start block. + (cmp:irc-br (iblock-tag (bir:start ir))) + ;; Lay out blocks. + (bir:do-iblocks (ib ir) + (layout-iblock ib abi))))) the-function) (defun layout-main-function (function lambda-name abi @@ -1901,14 +1903,6 @@ 'perform-optimization) (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) - (cmp:with-irbuilder (body-irbuilder) - (bir:map-iblocks - (lambda (ib) - (setf (gethash ib *tags*) - (cmp:irc-basic-block-create - (iblock-name ib))) - (initialize-iblock-translation ib)) - function)) (cmp:irc-set-insert-point-basic-block entry-block cmp:*irbuilder-function-alloca*) (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) @@ -1917,7 +1911,10 @@ (:lineno (core:source-pos-info-lineno source-pos-info)) (layout-main-function* the-function function body-irbuilder body-block - abi :linkage linkage)))))))) + abi :linkage linkage) + ;; Finish up by jumping from the entry block to the body. + (cmp:irc-br body-block)))))) + the-function)) (defun compute-rest-alloc (cleavir-lambda-list-analysis) ;; FIXME: We seriously need to not reparse lambda lists a million times From 35ef6067e68e0eae398d9b0fb8741dce40b95ad6 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 23 Apr 2024 16:47:24 -0400 Subject: [PATCH 02/37] Destroy old compiler debug info mechanism I'm going to remake it entirely and this is a rare opportunity where I can start mostly from scratch without breaking everything. (tests now fail, so some things are still broken) Bytecode debug info is fine & will be fine since it's fine. --- src/lisp/cscript.lisp | 1 - src/lisp/kernel/clasp-builder.lisp | 1 + src/lisp/kernel/cleavir/translate-btb.lisp | 99 ++-- src/lisp/kernel/cleavir/translate.lisp | 170 ++++--- src/lisp/kernel/cmp/cmpexports.lisp | 15 +- src/lisp/kernel/cmp/cmprunall.lisp | 35 +- .../kernel/cmp/compile-file-parallel.lisp | 36 +- src/lisp/kernel/cmp/compile-file.lisp | 17 +- src/lisp/kernel/cmp/debuginfo.lisp | 421 ------------------ src/lisp/kernel/cmp/workbench.lisp | 4 - src/lisp/kernel/init.lisp | 2 - 11 files changed, 162 insertions(+), 639 deletions(-) delete mode 100644 src/lisp/kernel/cmp/debuginfo.lisp diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp index 36aaec38e7..d289f2f6e1 100644 --- a/src/lisp/cscript.lisp +++ b/src/lisp/cscript.lisp @@ -37,7 +37,6 @@ #~"kernel/cmp/startup-primitives.lisp" #~"kernel/cmp/primitives.lisp" #~"kernel/cmp/cmpir.lisp" - #~"kernel/cmp/debuginfo.lisp" #~"kernel/cmp/cmprunall.lisp" #~"kernel/cmp/cmpliteral.lisp" #~"kernel/cmp/typeq.lisp" diff --git a/src/lisp/kernel/clasp-builder.lisp b/src/lisp/kernel/clasp-builder.lisp index ba2665b7db..1c464a3914 100644 --- a/src/lisp/kernel/clasp-builder.lisp +++ b/src/lisp/kernel/clasp-builder.lisp @@ -234,6 +234,7 @@ "Call make-create-file-args with each system path and the installed path so that when the DIFile is actually created the argument list passed to llvm-sys:create-file will have already been initialized with install path versus the build path of the source code file." + #+(or) (mapc #'(lambda (entry &aux (source-path (getf entry :source-path)) (install-path (getf entry :install-path))) (funcall make-create-file-args source-path (namestring source-path) install-path)) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index d08053aee1..e72b5ce5cf 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -194,30 +194,30 @@ when import ; skip unused fixed closure entries collect (cmp:irc-t*-load-atomic (cmp::gen-memref-address closure-vec offset)))) + #+(or) (source-pos-info (cc::function-source-pos-info ir))) ;; Tail call the real function. - (cmp:with-debug-info-source-position (source-pos-info) - (let* ((main-function (cc::main-function llvm-function-info)) - (function-type (llvm-sys:get-function-type main-function)) - (arguments - (mapcar (lambda (arg) - (cc::translate-cast (cc::in arg) - '(:object) (cc-bmir:rtype arg))) - (core:arguments llvm-function-info))) - (c - (cmp:irc-create-call-wft - function-type main-function - ;; Augment the environment lexicals as a local call would. - (nconc environment-values arguments))) - (returni (bir:returni ir)) - (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) - #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) - ;; Box/etc. results of the local call. - (if returni - (cmp:irc-ret (cc::translate-cast - (cc::local-call-rv->inputs c rrtype) - rrtype :multiple-values)) - (cmp:irc-unreachable))))))) + (let* ((main-function (cc::main-function llvm-function-info)) + (function-type (llvm-sys:get-function-type main-function)) + (arguments + (mapcar (lambda (arg) + (cc::translate-cast (cc::in arg) + '(:object) (cc-bmir:rtype arg))) + (core:arguments llvm-function-info))) + (c + (cmp:irc-create-call-wft + function-type main-function + ;; Augment the environment lexicals as a local call would. + (nconc environment-values arguments))) + (returni (bir:returni ir)) + (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) + #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) + ;; Box/etc. results of the local call. + (if returni + (cmp:irc-ret (cc::translate-cast + (cc::local-call-rv->inputs c rrtype) + rrtype :multiple-values)) + (cmp:irc-unreachable)))))) xep) (defun layout-xep-function (xep arity ir lambda-list-analysis lambda-name) @@ -235,34 +235,29 @@ (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) (source-pos-info (cc::function-source-pos-info ir)) (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function xep) - (llvm-sys:set-personality-fn xep (cmp:irc-personality-function)) - (llvm-sys:add-fn-attr2string xep "uwtable" "async") - (when (null (bir:returni ir)) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy ir) - 'perform-optimization) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (when sys:*drag-native-calls* - (cmp::irc-intrinsic "drag_native_calls")) - (let ((calling-convention - (cmp:setup-calling-convention xep - arity - :debug-on - (policy:policy-value - (bir:policy ir) - 'save-register-args) - :cleavir-lambda-list-analysis lambda-list-analysis - :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) - (layout-xep-function* xep arity ir lambda-list-analysis calling-convention)))))))) + (llvm-sys:set-personality-fn xep (cmp:irc-personality-function)) + (llvm-sys:add-fn-attr2string xep "uwtable" "async") + (when (null (bir:returni ir)) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy ir) + 'perform-optimization) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr xep 'llvm-sys:attribute-optimize-none)) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (when sys:*drag-native-calls* + (cmp::irc-intrinsic "drag_native_calls")) + (let ((calling-convention + (cmp:setup-calling-convention xep + arity + :debug-on + (policy:policy-value + (bir:policy ir) + 'save-register-args) + :cleavir-lambda-list-analysis lambda-list-analysis + :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) + (layout-xep-function* xep arity ir lambda-list-analysis calling-convention))))) (defun layout-xep-group (function lambda-name abi) (declare (ignore abi)) @@ -351,9 +346,7 @@ (cc::*function-info* (make-hash-table :test #'eq)) (cc::*literal-fn* #'reference-literal)) (cmp::with-module (:module module) - (cmp:with-debug-info-generator (:module module - :pathname debug-namestring) - (layout-module bir-module abi :toplevels toplevels)) + (layout-module bir-module abi :toplevels toplevels) (cmp:irc-verify-module-safe module) (cmp::potentially-save-module)) (make-instance 'translation diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index cbc591f720..8f1afc269d 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -166,20 +166,16 @@ (origin-source (bir:origin inst))) ;;; Put in source info. +#+(or) (defmethod translate-simple-instruction :around ((instruction bir:instruction) abi) (declare (ignore abi)) - (cmp:with-debug-info-source-position ((ensure-origin - (inst-source instruction) - 999902)) - (call-next-method))) + (call-next-method)) +#+(or) (defmethod translate-terminator :around ((instruction bir:instruction) abi next) (declare (ignore abi next)) - (cmp:with-debug-info-source-position ((ensure-origin - (inst-source instruction) - 999903)) - (call-next-method))) + (call-next-method)) (defmethod translate-terminator ((instruction bir:unreachable) abi next) @@ -1808,28 +1804,27 @@ (cmp::gen-memref-address closure-vec offset)))) (source-pos-info (function-source-pos-info ir))) ;; Tail call the real function. - (cmp:with-debug-info-source-position (source-pos-info) - (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info))) - (arguments - (mapcar (lambda (arg) - (translate-cast (in arg) - '(:object) (cc-bmir:rtype arg))) - (arguments llvm-function-info))) - (c - (cmp:irc-create-call-wft - function-type - (main-function llvm-function-info) - ;; Augment the environment lexicals as a local call would. - (nconc environment-values arguments))) - (returni (bir:returni ir)) - (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) - #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) - ;; Box/etc. results of the local call. - (if returni - (cmp:irc-ret (translate-cast - (local-call-rv->inputs c rrtype) - rrtype :multiple-values)) - (cmp:irc-unreachable))))))) + (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info))) + (arguments + (mapcar (lambda (arg) + (translate-cast (in arg) + '(:object) (cc-bmir:rtype arg))) + (arguments llvm-function-info))) + (c + (cmp:irc-create-call-wft + function-type + (main-function llvm-function-info) + ;; Augment the environment lexicals as a local call would. + (nconc environment-values arguments))) + (returni (bir:returni ir)) + (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) + #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) + ;; Box/etc. results of the local call. + (if returni + (cmp:irc-ret (translate-cast + (local-call-rv->inputs c rrtype) + rrtype :multiple-values)) + (cmp:irc-unreachable)))))) the-function) (defun layout-main-function* (the-function ir @@ -1886,34 +1881,27 @@ (body-block (cmp:irc-basic-block-create "body")) (source-pos-info (function-source-pos-info function)) (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function the-function) - #+(or)(llvm-sys:set-calling-conv the-function 'llvm-sys:fastcc) - (llvm-sys:set-personality-fn the-function - (cmp:irc-personality-function)) - ;; we'd like to be able to be interruptable at any time, so we - ;; need async-safe unwinding tables basically everywhere. - ;; (Although in code that ignores interrupts we could loosen this.) - (llvm-sys:add-fn-attr2string the-function "uwtable" "async") - (when (null (bir:returni function)) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy function) - 'perform-optimization) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (cmp:with-dbg-lexical-block - (:lineno (core:source-pos-info-lineno source-pos-info)) - (layout-main-function* the-function function - body-irbuilder body-block - abi :linkage linkage) - ;; Finish up by jumping from the entry block to the body. - (cmp:irc-br body-block)))))) + #+(or)(llvm-sys:set-calling-conv the-function 'llvm-sys:fastcc) + (llvm-sys:set-personality-fn the-function + (cmp:irc-personality-function)) + ;; we'd like to be able to be interruptable at any time, so we + ;; need async-safe unwinding tables basically everywhere. + ;; (Although in code that ignores interrupts we could loosen this.) + (llvm-sys:add-fn-attr2string the-function "uwtable" "async") + (when (null (bir:returni function)) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy function) + 'perform-optimization) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (layout-main-function* the-function function + body-irbuilder body-block + abi :linkage linkage) + ;; Finish up by jumping from the entry block to the body. + (cmp:irc-br body-block)) the-function)) (defun compute-rest-alloc (cleavir-lambda-list-analysis) @@ -1946,40 +1934,33 @@ (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) (source-pos-info (function-source-pos-info function)) (lineno (core:source-pos-info-lineno source-pos-info))) - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno lineno - :function-type llvm-function-type - :function xep-arity-function) - (llvm-sys:set-personality-fn xep-arity-function - (cmp:irc-personality-function)) - (llvm-sys:add-fn-attr2string xep-arity-function - "uwtable" "async") - (when (null (bir:returni function)) - (llvm-sys:add-fn-attr xep-arity-function - 'llvm-sys:attribute-no-return)) - (unless (policy:policy-value (bir:policy function) - 'perform-optimization) - (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-no-inline) - (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (cmp:with-debug-info-source-position (source-pos-info) - (if sys:*drag-native-calls* - (cmp::irc-intrinsic "drag_native_calls")) - (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) - (calling-convention - (cmp:setup-calling-convention xep-arity-function - arity - :debug-on - (policy:policy-value - (bir:policy function) - 'save-register-args) - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) - (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))))) - - + (llvm-sys:set-personality-fn xep-arity-function + (cmp:irc-personality-function)) + (llvm-sys:add-fn-attr2string xep-arity-function + "uwtable" "async") + (when (null (bir:returni function)) + (llvm-sys:add-fn-attr xep-arity-function + 'llvm-sys:attribute-no-return)) + (unless (policy:policy-value (bir:policy function) + 'perform-optimization) + (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-no-inline) + (llvm-sys:add-fn-attr xep-arity-function 'llvm-sys:attribute-optimize-none)) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (if sys:*drag-native-calls* + (cmp::irc-intrinsic "drag_native_calls")) + (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (calling-convention + (cmp:setup-calling-convention xep-arity-function + arity + :debug-on + (policy:policy-value + (bir:policy function) + 'save-register-args) + :cleavir-lambda-list-analysis cleavir-lambda-list-analysis + :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) + (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi))))))))) (defun maybe-note-return-cast (function) @@ -2228,9 +2209,8 @@ COMPILE-FILE will use the default *clasp-env*." (cmp::cmp-log "Dumping module%N") (cmp::cmp-log-dump-module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) - (cmp:with-debug-info-generator (:module cmp:*the-module* :pathname pathname) - (literal:with-rtv - (translate bir :linkage linkage :abi abi))) + (literal:with-rtv + (translate bir :linkage linkage :abi abi)) (declare (ignore constants-table)) (jit-add-module-return-function cmp:*the-module* startup-shutdown-id ordered-raw-constants-list))))) diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp index db72e124c7..fbf1e5a6bb 100644 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ b/src/lisp/kernel/cmp/cmpexports.lisp @@ -1,7 +1,6 @@ (in-package :cmp) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(with-debug-info-source-position - calculate-cleavir-lambda-list-analysis + (export '(calculate-cleavir-lambda-list-analysis module-report transform-lambda-parts codegen-startup-shutdown @@ -135,8 +134,6 @@ cmp-log cmp-log-dump-module cmp-log-dump-function - make-file-metadata - make-function-metadata function-info function-info-cleavir-lambda-list-analysis make-function-info @@ -319,15 +316,6 @@ cleavir-lambda-list-analysis-rest process-bir-lambda-list typeid-core-unwind - *dbg-generate-dwarf* - *dbg-current-function-metadata* - *dbg-current-function-lineno* - *dbg-current-scope* - with-guaranteed-*current-source-pos-info* - with-dbg-function - with-dbg-lexical-block - dbg-variable-alloca - dbg-variable-value compile-file-source-pos-info c++-field-offset c++-field-index @@ -335,7 +323,6 @@ c++-struct*-type c++-field-ptr %closure%.offset-of[n]/t* - with-debug-info-generator with-irbuilder with-landing-pad make-uintptr_t diff --git a/src/lisp/kernel/cmp/cmprunall.lisp b/src/lisp/kernel/cmp/cmprunall.lisp index 92d7d3cdbb..5c0e955d54 100644 --- a/src/lisp/kernel/cmp/cmprunall.lisp +++ b/src/lisp/kernel/cmp/cmprunall.lisp @@ -39,26 +39,21 @@ load-time-value manager (true - in COMPILE-FILE) or not (false - in COMPILE)." (*irbuilder-run-all-alloca* irbuilder-alloca) (*irbuilder-run-all-body* irbuilder-body) (*current-function* run-all-fn)) - (cmp-log "Entering with-dbg-function%N") - (cmp:with-guaranteed-*current-source-pos-info* () - (cmp:with-dbg-function (:lineno 0 - :function run-all-fn - :function-type (cmp:fn-prototype :general-entry)) - ;; Set up dummy debug info for these irbuilders - (let ((entry-bb (irc-basic-block-create "entry" run-all-fn))) - (irc-set-insert-point-basic-block entry-bb irbuilder-alloca)) - (cmp-log "bb work do-make-new-run-all%N") - (let ((body-bb (irc-basic-block-create "body" run-all-fn))) - (irc-set-insert-point-basic-block body-bb irbuilder-body) - ;; Setup exception handling and cleanup landing pad - (with-irbuilder (irbuilder-alloca) - (let ((entry-branch (irc-br body-bb))) - (irc-set-insert-point-instruction entry-branch irbuilder-alloca) - (with-irbuilder (irbuilder-body) - (progn - (cmp-log "running body do-make-new-run-all%N") - (funcall body run-all-fn)) - (irc-ret-null-t*)))))))) + ;; Set up dummy debug info for these irbuilders + (let ((entry-bb (irc-basic-block-create "entry" run-all-fn))) + (irc-set-insert-point-basic-block entry-bb irbuilder-alloca)) + (cmp-log "bb work do-make-new-run-all%N") + (let ((body-bb (irc-basic-block-create "body" run-all-fn))) + (irc-set-insert-point-basic-block body-bb irbuilder-body) + ;; Setup exception handling and cleanup landing pad + (with-irbuilder (irbuilder-alloca) + (let ((entry-branch (irc-br body-bb))) + (irc-set-insert-point-instruction entry-branch irbuilder-alloca) + (with-irbuilder (irbuilder-body) + (progn + (cmp-log "running body do-make-new-run-all%N") + (funcall body run-all-fn)) + (irc-ret-null-t*)))))) (values run-all-fn))) (defmacro with-make-new-run-all ((run-all-fn &optional (name-suffix '(core:fmt nil "*{}" (core:next-number)))) &body body) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index 6ecf063e85..a468ed5592 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -155,26 +155,24 @@ (with-module (:module module :optimize (when optimize #'llvm-sys:optimize-module) :optimize-level optimize-level) - (with-debug-info-generator (:module module - :pathname *compile-file-source-debug-pathname*) - (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) - (with-literal-table (:id (ast-job-form-index job)) - (core:with-memory-ramp (:pattern 'gctools:ramp) - (literal:arrange-thunk-as-top-level - (clasp-cleavir-translate-bir::translate-ast - (ast-job-ast job))))) - (let ((startup-function (add-global-ctor-function module run-all-function - :position (ast-job-form-counter job)))) + (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) + (with-literal-table (:id (ast-job-form-index job)) + (core:with-memory-ramp (:pattern 'gctools:ramp) + (literal:arrange-thunk-as-top-level + (clasp-cleavir-translate-bir::translate-ast + (ast-job-ast job))))) + (let ((startup-function (add-global-ctor-function module run-all-function + :position (ast-job-form-counter job)))) ;;; (add-llvm.used module startup-function) - (add-llvm.global_ctors module 15360 startup-function) - (setf (ast-job-startup-function-name job) (llvm-sys:get-name startup-function)) - ;; The link-once-odrlinkage should keep the startup-function alive and that - ;; should keep everything else alive as well. - ) - #+(or) - (make-boot-function-global-variable module run-all-function - :position (ast-job-form-index job) - ))) + (add-llvm.global_ctors module 15360 startup-function) + (setf (ast-job-startup-function-name job) (llvm-sys:get-name startup-function)) + ;; The link-once-odrlinkage should keep the startup-function alive and that + ;; should keep everything else alive as well. + ) + #+(or) + (make-boot-function-global-variable module run-all-function + :position (ast-job-form-index job) + )) (cmp-log "About to verify the module%N") (cmp-log-dump-module module) (irc-verify-module-safe module) diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index f2aada8929..54b267cbfb 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -181,16 +181,13 @@ Compile a Lisp source stream and return a corresponding LLVM module." :optimize (when optimize #'llvm-sys:optimize-module) :optimize-level optimize-level) ;; (1) Generate the code - (cmp-log "About to with-debug-info-generator%N") - (with-debug-info-generator (:module *the-module* - :pathname *compile-file-source-debug-pathname*) - (cmp-log "About to with-make-new-run-all%N") - (with-make-new-run-all (run-all-function name) - (cmp-log "About to with-literal-table%N") - (with-literal-table (:id 0) - (cmp-log "About to loop-read-and-compile-file-forms%N") - (loop-read-and-compile-file-forms source-sin environment)) - (setf run-all-name (llvm-sys:get-name run-all-function)))) + (cmp-log "About to with-make-new-run-all%N") + (with-make-new-run-all (run-all-function name) + (cmp-log "About to with-literal-table%N") + (with-literal-table (:id 0) + (cmp-log "About to loop-read-and-compile-file-forms%N") + (loop-read-and-compile-file-forms source-sin environment)) + (setf run-all-name (llvm-sys:get-name run-all-function))) (cmp-log "About to verify the module%N") (cmp-log-dump-module *the-module*) (irc-verify-module-safe *the-module*) diff --git a/src/lisp/kernel/cmp/debuginfo.lisp b/src/lisp/kernel/cmp/debuginfo.lisp deleted file mode 100644 index c77a104bff..0000000000 --- a/src/lisp/kernel/cmp/debuginfo.lisp +++ /dev/null @@ -1,421 +0,0 @@ -;;; -;;; File: debuginfo.lisp -;;; - -;; Copyright (c) 2014, Christian E. Schafmeister -;; -;; CLASP is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Library General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. -;; -;; See directory 'clasp/licenses' for full details. -;; -;; The above copyright notice and this permission notice shall be included in -;; all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -;; THE SOFTWARE. - -;; -^- - -(in-package :cmp) - -;;; These variables are pretty important to what debug information actually goes -;;; into the file. For example, and as a note to later developers, I just got bit -;;; by the fact that a source position info's filename is often irrelevant - the -;;; dbg-current-scope and dbg-current-file are used. -;;; (defvar *dbg-generate-dwarf* t) <<--- defined in init.lisp -(defvar *dbg-compile-unit*) -(defvar *dbg-current-file*) -(defvar *dbg-current-function-metadata*) -(defvar *dbg-current-function-lineno*) -(defvar *dbg-current-scope* nil - "Stores the current enclosing lexical scope for debugging info") -;;; Unlike other DI structures, each call to create-function seems to result -;;; in a distinct DISubprogram - not our intention. So we hash on the scope. -;;; ATM function scopes are lists so an EQUAL hash table is fine here. -(defvar *dbg-function-metadata-cache*) -;;; We make a cache for file metadata just to save time and make reproducible -;;; builds possible -(defvar *dbg-file-metadata-cache* (make-hash-table :test #'equal)) - -(defun dbg-create-function-type (difile function-type) - (declare (ignore difile function-type)) - "Currently create a bogus function type" - (let ((arg-array (llvm-sys:get-or-create-type-array *the-module-dibuilder* - (list - (llvm-sys:create-basic-type *the-module-dibuilder* - "int" 64 - llvm-sys:+dw-ate-signed-fixed+ - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero))))))) - (llvm-sys:create-subroutine-type *the-module-dibuilder* arg-array - (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero)) - 0))) - -(defmacro with-dibuilder ((module) &rest body) - `(let ((*the-module-dibuilder* (llvm-sys:make-dibuilder ,module))) - (unwind-protect - (progn ,@body) - (llvm-sys:finalize *the-module-dibuilder*) - ;; add the flag that defines the Dwarf Version - (llvm-sys:add-module-flag *the-module* - (llvm-sys:mdnode-get (thread-local-llvm-context) - (list - (llvm-sys:value-as-metadata-get (jit-constant-i32 2)) - (llvm-sys:mdstring-get (thread-local-llvm-context) "Dwarf Version") - (llvm-sys:value-as-metadata-get (jit-constant-i32 +debug-dwarf-version+))))) - (llvm-sys:add-module-flag *the-module* - (llvm-sys:mdnode-get (thread-local-llvm-context) - (list - (llvm-sys:value-as-metadata-get (jit-constant-i32 2)) - (llvm-sys:mdstring-get (thread-local-llvm-context) "Debug Info Version") - (llvm-sys:value-as-metadata-get (jit-constant-i32 llvm-sys:+debug-metadata-version+)))))))) - -(defmacro with-dbg-compile-unit ((source-pathname) &rest body) - (let ((path (gensym)) - (file (gensym)) - (dir-name (gensym))) - `(let* ((,path (pathname ,source-pathname)) - (,file *dbg-current-file*) - (,dir-name (directory-namestring ,path)) - (*dbg-function-metadata-cache* (make-hash-table :test #'equal)) - (*dbg-compile-unit* (llvm-sys:create-compile-unit - *the-module-dibuilder* ; dibuilder - llvm-sys:dw-lang-c-plus-plus ; 1 llvm-sys:dw-lang-common-lisp - ,file ; 2 file - "clasp Common Lisp compiler" ; 4 producer - nil ; 5 isOptimized - "-v" ; 6 compiler flags - 1 ; 7 RV run-time version - "the-split-name.log" ; 8 splitname - :full-debug ; 9 DebugEmissionKind (:full-debug :line-tables-only) - 0 ; 10 DWOld - t ; 11 SplitDebugInlining - nil ; 12 DebugInfoForProfiling - :dntk-default ; 13 DebugNameTableKind - nil ; 14 RangesBaseAddress - "" ; 15 SysRoot (-isysroot value) - "" ; 16 SDK - ))) - (declare (ignorable ,dir-name)) ; cmp-log may expand empty - (cmp-log "with-dbg-compile-unit *dbg-compile-unit*: {}%N" *dbg-compile-unit*) - (cmp-log "with-dbg-compile-unit source-pathname: {}%N" ,source-pathname) - (cmp-log "with-dbg-compile-unit file-name: [{}]%N" ,file) - (cmp-log "with-dbg-compile-unit dir-name: [{}]%N" ,dir-name) - ,@body))) - -(defun do-make-create-file-args (pathname logical-pathname) - (let ((filename (file-namestring pathname)) - (directory (namestring (make-pathname :name nil :type nil :defaults pathname)))) - (list filename - (if (zerop (length directory)) - "." - (string-right-trim '(#\/) directory)) - nil - (if logical-pathname - ;; If we include the source we should put this at the end - (core:fmt nil ";; LOGICAL-PATHNAME={}%n" logical-pathname) - ;; KLUDGE: LLVM complains "inconsistent use of embedded source" - ;; if some DIFiles have a source field and some don't. - ";;")))) - -(defun make-create-file-args (pathname namestring &optional install-pathname) - (let (args) - (if (typep pathname 'logical-pathname) - (let ((translated-path (translate-logical-pathname pathname))) - (setq args (do-make-create-file-args (or install-pathname translated-path) namestring)) - (funcall #'(setf gethash) args translated-path *dbg-file-metadata-cache*)) - (setq args (do-make-create-file-args (or install-pathname pathname) nil))) - (funcall #'(setf gethash) args pathname *dbg-file-metadata-cache*))) - -(defun make-file-metadata (path) - (let ((namestring (if (typep path 'pathname) - (namestring path) - path)) - (pathname (if (typep path 'pathname) - path - (parse-namestring path)))) - (multiple-value-bind (args foundp) - (gethash path *dbg-file-metadata-cache*) - (apply #'llvm-sys:create-file *the-module-dibuilder* - (if foundp args (make-create-file-args pathname namestring)))))) - -(defmacro with-dbg-file-descriptor ((source-pathname) &rest body) - `(let ((*dbg-current-file* (make-file-metadata (pathname ,source-pathname)))) - ,@body)) - -(defmacro with-debug-info-generator ((&key module pathname) &rest body) - "One macro that uses three other macros" - (let ((body-func (gensym))) - `(flet ((,body-func () ,@body)) - (if *dbg-generate-dwarf* - (with-dibuilder (,module) - (with-dbg-file-descriptor (,pathname) - (with-dbg-compile-unit (,pathname) - (funcall #',body-func)))) - (funcall #',body-func))))) - -(defun make-function-metadata (&key file-metadata linkage-name function-type lineno) - (llvm-sys:create-function - *the-module-dibuilder* ; 0 DIBuilder - file-metadata ; 1 function scope - linkage-name ; 2 function name - linkage-name ; 3 function name - file-metadata ; 4 file where function is defined - lineno ; 5 lineno - (dbg-create-function-type file-metadata function-type) ; 6 function-type - lineno ; 7 scopeLine - set to the beginning of the scope this starts - (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero)) ; 8 flags - (core:enum-logical-or llvm-sys:dispflag-enum '(llvm-sys:dispflag-definition)) ; 9 spflags - nil ; 10 TParam = nullptr - nil ; 11 Decl = nullptr - nil ; 12 ThrownTypes = nullptr - nil ; 13 Annotations = nullptr - "" ; 14 TargetFunctionName = "" - #| -(DIScope *Scope, ; 1 - StringRef Name, ; 2 - StringRef LinkageName, ;3 - DIFile *File, ;4 - unsigned LineNo, ; 5 - DISubroutineType *Ty, ; 6 - unsigned ScopeLine, ; 7 - DINode::DIFlags Flags=DINode::FlagZero, ; 8 - DISubprogram::DISPFlags SPFlags=DISubprogram::SPFlagZero, ; 9 - DITemplateParameterArray TParams=nullptr, - DISubprogram *Decl=nullptr, - DITypeArray ThrownTypes=nullptr) -|# - )) - -(defun do-dbg-function (closure lineno function-type function) - (declare (ignore function-type)) - (unless *current-source-pos-info* - (warn "*current-source-pos-info* is undefined - this may cause problems - wrap with-dbg-function in with-guaranteed-*current-source-pos-info* to fix this")) - (let ((linkage-name (llvm-sys:get-name function))) - (multiple-value-bind (file-scope file-handle) - (core:file-scope (llvm-sys:get-path *dbg-current-file*)) - (declare (ignore file-scope)) - (if (and *dbg-generate-dwarf* *the-module-dibuilder*) - (let* ((current-subprogram (cached-function-scope (list linkage-name lineno file-handle))) - (*dbg-current-function-metadata* current-subprogram) - (*dbg-current-scope* current-subprogram) - (*dbg-current-function-lineno* lineno)) - (llvm-sys:set-subprogram function current-subprogram) - (funcall closure)) - (funcall closure))))) - -(defmacro with-guaranteed-*current-source-pos-info* (() &rest body) - `(let ((core:*current-source-pos-info* (if core:*current-source-pos-info* - core:*current-source-pos-info* - (core:make-source-pos-info :filename "dummy-filename")))) - (progn - ,@body))) - -(defmacro with-dbg-function ((&key lineno function-type function) &rest body) - (cmp-log "Entered with-dbg-function%N") - `(do-dbg-function - (lambda () (progn ,@body)) - ,lineno ,function-type ,function)) - -(defvar *with-dbg-lexical-block* nil) - -(defun do-dbg-lexical-block (closure lineno) - (let ((*with-dbg-lexical-block* t)) - (if (and *dbg-generate-dwarf* *the-module-dibuilder*) - (progn - (unless *dbg-current-scope* - (error "The *dbg-current-scope* is nil - it cannot be when create-lexical-block is called")) - ;; TODO: Dwarf path discriminator - (let* ((*dbg-current-scope* (llvm-sys:create-lexical-block *the-module-dibuilder* - *dbg-current-scope* - *dbg-current-file* - lineno 0))) - (cmp-log "with-dbg-lexical-block%N") - (funcall closure))) - (funcall closure)))) - -(defmacro with-dbg-lexical-block - ((&key (lineno (core:source-pos-info-lineno core:*current-source-pos-info*))) - &body body) - `(do-dbg-lexical-block (lambda () ,@body) ,lineno)) - -(defun dbg-clear-irbuilder-source-location (irbuilder) - (llvm-sys:clear-current-debug-location irbuilder)) - -(defun cached-file-metadata (file-handle) - ;; n.b. despite the name we don't cache, as llvm seems to handle it - (make-file-metadata (file-scope-pathname (file-scope file-handle)))) - -(defun cached-function-scope (function-scope-info &optional function-type) - ;; See production in cleavir/inline-prep.lisp - #+(or cclasp eclasp) - (when core:*debug-source-pos-info* - (let ((name (car function-scope-info))) - (when (char= #\^ (elt name (1- (length name)))) - (break "The name ~s ends in ^" name)))) - (multiple-value-bind (value found) - (gethash function-scope-info *dbg-function-metadata-cache*) - (if found - (values value :found-in-cache) - (values (setf (gethash function-scope-info *dbg-function-metadata-cache*) - (destructuring-bind (function-name lineno file-handle) - function-scope-info - (make-function-metadata :linkage-name function-name - :lineno lineno - :function-type (if function-type - function-type - (fn-prototype :general-entry)) - :file-metadata (cached-file-metadata file-handle)))) - :created)))) - -(defparameter *trap-zero-lineno* nil) - -(defun get-dilocation (spi dbg-current-scope) - (let* ((file-handle (core:source-pos-info-file-handle spi)) - (lineno (core:source-pos-info-lineno spi)) - (col (core:source-pos-info-column spi)) - (fsi (core:source-pos-info-function-scope spi)) - (inlined-at (core:source-pos-info-inlined-at spi)) - (scope (if inlined-at (cached-function-scope fsi) dbg-current-scope))) - (declare (ignore file-handle)) - (when (and *trap-zero-lineno* (zerop lineno)) - (format *error-output* "In get-dilocation lineno was zero! Setting to ~d~%" - (setf lineno 666666))) - (if inlined-at - (llvm-sys:get-dilocation (thread-local-llvm-context) - lineno col scope - (get-dilocation inlined-at dbg-current-scope)) - (llvm-sys:get-dilocation (thread-local-llvm-context) - lineno col scope)))) - -(defun dbg-set-irbuilder-source-location (irbuilder spi) - (when *dbg-generate-dwarf* - (let ((diloc (get-dilocation spi *dbg-current-scope*))) - (llvm-sys:set-current-debug-location irbuilder diloc)))) - -(defun dbg-create-auto-variable (&key (scope *dbg-current-scope*) - name (file *dbg-current-file*) - lineno type always-preserve) - (llvm-sys:create-auto-variable *the-module-dibuilder* - scope name file lineno type always-preserve - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero)) - ;; FIXME: I'm guessing - 64)) - -(defun dbg-create-parameter-variable - (&key (scope *dbg-current-scope*) name argno (file *dbg-current-file*) - lineno type always-preserve annotations) - (progn - (unless (> argno 0) - (error "The argno for ~a must start at 1 - got ~a" name argno)) - (llvm-sys:create-parameter-variable *the-module-dibuilder* - scope - name - argno - file - lineno - type - always-preserve - (core:enum-logical-or llvm-sys:diflags-enum - '(llvm-sys:diflags-zero)) - annotations))) - -(defun dbg-parameter-var (name argno &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (dbg-create-parameter-variable :name name :argno argno - :lineno *dbg-current-function-lineno* - :type (llvm-sys:create-basic-type - *the-module-dibuilder* - type-name 64 type 0) - :always-preserve t)) - -(defun %dbg-variable-addr (addr var) - (let* ((addrmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:value-as-metadata-get addr))) - (varmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - var)) - (diexpr (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:create-expression-none *the-module-dibuilder*)))) - (irc-intrinsic "llvm.dbg.addr" addrmd varmd diexpr))) - -;;; Put in debug information for a variable corresponding to an alloca. -(defun dbg-variable-alloca (alloca name spi - &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (when spi ; don't bother if there's no info. - (let* ((type (llvm-sys:create-basic-type - *the-module-dibuilder* type-name 64 type 0)) - (fsi (core:source-pos-info-function-scope spi)) - (scope (if fsi - (cached-function-scope fsi) - *dbg-current-scope*)) - (auto-variable (dbg-create-auto-variable - :name name - :lineno (core:source-pos-info-lineno spi) - :scope scope - :type type))) - (%dbg-variable-addr alloca auto-variable)))) - -(defun %dbg-variable-value (value var) - (let* ((valuemd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:value-as-metadata-get value))) - (varmd (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - var)) - (diexpr (llvm-sys:metadata-as-value-get - (thread-local-llvm-context) - (llvm-sys:create-expression-none *the-module-dibuilder*)))) - (irc-intrinsic "llvm.dbg.value" valuemd varmd diexpr))) - -;;; Put in debug information for a variable corresponding to an llvm Value. -(defun dbg-variable-value (value name spi - &optional (type-name "T_O*") - (type llvm-sys:+dw-ate-address+)) - (when spi - (let* ((type (llvm-sys:create-basic-type - *the-module-dibuilder* type-name 64 type 0)) - (fsi (core:source-pos-info-function-scope spi)) - (scope (if fsi - (cached-function-scope fsi) - *dbg-current-scope*)) - (auto-variable (dbg-create-auto-variable - :name name - :lineno (core:source-pos-info-lineno spi) - :scope scope - :type type))) - (unless auto-variable - (error "maybe-spill-to-register-save-area auto-variable is NIL")) - (%dbg-variable-value value auto-variable)))) - -(defun set-instruction-source-position (origin function-metadata) - (when *dbg-generate-dwarf* - (if origin - (let ((source-pos-info (if (consp origin) - (car origin) - origin)) - (*dbg-current-scope* function-metadata)) - (dbg-set-irbuilder-source-location *irbuilder* source-pos-info)) - (dbg-clear-irbuilder-source-location *irbuilder*)))) - -(defun do-debug-info-source-position (origin body-lambda) - (unwind-protect - (progn - (set-instruction-source-position origin *dbg-current-function-metadata*) - (funcall body-lambda)) - (set-instruction-source-position nil *dbg-current-function-metadata*))) - -(defmacro with-debug-info-source-position ((origin) &body body) - `(do-debug-info-source-position ,origin (lambda () ,@body))) diff --git a/src/lisp/kernel/cmp/workbench.lisp b/src/lisp/kernel/cmp/workbench.lisp index 15b4e896a6..5b0405601b 100644 --- a/src/lisp/kernel/cmp/workbench.lisp +++ b/src/lisp/kernel/cmp/workbench.lisp @@ -8,7 +8,6 @@ COMPILER:COMPILE-LAMBDA-FUNCTION COMPILER::GENERATE-LLVM-FUNCTION-FROM-CODE COMPILER::TRANSFORM-LAMBDA-PARTS COMPILE-FILE cmp::do-new-function - cmp::do-dbg-function cmp::compile-file-to-module cmp::loop-read-and-compile-file-forms cmp::bclasp-loop-read-and-compile-file-forms @@ -67,9 +66,6 @@ cmp::irc-create-call-wft cmp::irc-typed-gep cmp::irc-bit-cast - cmp::dbg-parameter-var - cmp::%dbg-variable-value - cmp::%dbg-variable-addr cmp::alloca-temp-values cmp::alloca-arguments cmp::alloca-register-save-area diff --git a/src/lisp/kernel/init.lisp b/src/lisp/kernel/init.lisp index 5ed8347e38..1ca449fa04 100644 --- a/src/lisp/kernel/init.lisp +++ b/src/lisp/kernel/init.lisp @@ -160,8 +160,6 @@ ;; Setup a few things for the CMP package (eval-when (:execute :compile-toplevel :load-toplevel) (core::select-package :cmp)) -(sys:*make-special '*dbg-generate-dwarf*) -(setq *dbg-generate-dwarf* (null (member :disable-dbg-generate-dwarf *features*))) (export '(link-fasoll-modules link-fasobc-modules)) ;;; Turn on aclasp/bclasp activation-frame optimization (sys:*make-special '*activation-frame-optimize*) From 6fe869007b603715ac7c4ee9f60e66bde3e986b1 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 24 Apr 2024 11:17:13 -0400 Subject: [PATCH 03/37] define lambda lists for DIBuilder extern defmethods to make it easier to use them --- src/llvmo/debugInfoExpose.cc | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/llvmo/debugInfoExpose.cc b/src/llvmo/debugInfoExpose.cc index c70a2705c9..5450cbb384 100644 --- a/src/llvmo/debugInfoExpose.cc +++ b/src/llvmo/debugInfoExpose.cc @@ -258,9 +258,11 @@ CL_VALUE_ENUM(kw::_sym_CSK_MD5, llvm::DIFile::CSK_MD5); // Use it as zero valu CL_VALUE_ENUM(kw::_sym_CSK_SHA1, llvm::DIFile::CSK_SHA1); // Use it as zero value. CL_END_ENUM(_sym_CSKEnum); +CL_LAMBDA(dibuilder addr); CL_LISPIFY_NAME(createExpression); CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::DIExpression * (llvm::DIBuilder::*)(llvm::ArrayRef)) & llvm::DIBuilder::createExpression); + CL_LISPIFY_NAME(createExpressionNone); DOCGROUP(clasp); CL_DEFUN llvm::DIExpression* llvm_sys__createExpressionNone(DIBuilder_sp dib) { return dib->wrappedPtr()->createExpression(); } @@ -275,12 +277,15 @@ CL_VALUE_ENUM(kw::_sym_DNTK_GNU, llvm::DICompileUnit::DebugNameTableKind::GNU); CL_VALUE_ENUM(kw::_sym_DNTK_None, llvm::DICompileUnit::DebugNameTableKind::None); CL_END_ENUM(_sym_DNTKEnum); +CL_LAMBDA(dibuilder lang file producer optimizedp flags runtime-version split-name emission-kind DW-old split-debug-inlining debug-info-for-profiling name-table-kind ranges-base-address sysroot sdk); CL_LISPIFY_NAME(createCompileUnit); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createCompileUnit); +CL_LAMBDA(dibuilder filename directory checksum source); CL_LISPIFY_NAME(createFile); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createFile); +CL_LAMBDA(dibuilder scope name linkage-name file lineno ty scope-line flags subprogram-flags template-params decl thrown-types annotations target-func-name); CL_LISPIFY_NAME(createFunction); CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::DISubprogram * (llvm::DIBuilder::*)(llvm::DIScope * Scope, llvm::StringRef Name, @@ -292,33 +297,47 @@ CL_EXTERN_DEFMETHOD(DIBuilder_O, llvm::StringRef TargetFunctionName)) & llvm::DIBuilder::createFunction); +CL_LAMBDA(dibuilder scope file lineno column); CL_LISPIFY_NAME(createLexicalBlock); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createLexicalBlock); + +CL_LAMBDA(dibuilder name size encoding flags); CL_LISPIFY_NAME(createBasicType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createBasicType); +CL_LAMBDA(dibuilder type name file lineno context alignment flags annotations); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createTypedef); +CL_LAMBDA(dibuilder pointee-type size alignment dwarf-address-space name annotations); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createPointerType); +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createNullPtrType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createNullPtrType); +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createUnspecifiedParameter); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createUnspecifiedParameter); +CL_LAMBDA(dibuilder parameter-types flags calling-convention); CL_LISPIFY_NAME(createSubroutineType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createSubroutineType); +CL_LAMBDA(dibuilder scope name file lineno type always-preserve-p flags alignment); CL_LISPIFY_NAME(createAutoVariable); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createAutoVariable); +CL_LAMBDA(dibuilder scope name argno file lineno type always-preserve-p flags annotations); CL_LISPIFY_NAME(createParameterVariable); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createParameterVariable); -CL_LISPIFY_NAME(insertDbgValueIntrinsicBasicBlock); +// We don't expose the instruction version since we don't really need it. +CL_LAMBDA(dibuilder val varinfo expr dilocation basic-block); +CL_LISPIFY_NAME(insertDbgValueIntrinsic); CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::Instruction * (llvm::DIBuilder::*)(llvm::Value * Val, llvm::DILocalVariable* VarInfo, llvm::DIExpression* Expr, const llvm::DILocation* DL, llvm::BasicBlock* InsertAtEnd)) & llvm::DIBuilder::insertDbgValueIntrinsic); +CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(finalize); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::finalize); ; +CL_LAMBDA(dibuilder subprogram); CL_LISPIFY_NAME(finalizeSubprogram); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::finalizeSubprogram); ; @@ -520,9 +539,12 @@ CL_DEFUN DWARFContext_sp DWARFContext_O::createDWARFContext(ObjectFile_sp ofi) { } CL_DEFMETHOD size_t DWARFContext_O::getNumCompileUnits() const { return this->wrappedPtr()->getNumCompileUnits(); } + +CL_LAMBDA(dwarf-context index); CL_LISPIFY_NAME(get-unit-at-index); CL_EXTERN_DEFMETHOD(DWARFContext_O, (llvm::DWARFUnit * (llvm::DWARFContext::*)(unsigned int)) & llvm::DWARFContext::getUnitAtIndex); +CL_LAMBDA(dwarf-context unit); CL_LISPIFY_NAME(get-line-table-for-unit); CL_EXTERN_DEFMETHOD(DWARFContext_O, (const llvm::DWARFDebugLine::LineTable* (llvm::DWARFContext::*)(DWARFUnit*)) & llvm::DWARFContext::getLineTableForUnit); From 4b4df0a8f9cc22d3a7a9bcfea554c3c58450f555 Mon Sep 17 00:00:00 2001 From: Bike Date: Mon, 29 Apr 2024 15:38:26 -0400 Subject: [PATCH 04/37] Start on new debug info system It works well enough to get function names and arguments into backtraces. Which is really pretty much everything since argument parsing is hard, so. It's probably busted w/r/t inlining. --- src/lisp/kernel/cleavir/clasp-cleavir.asd | 1 + src/lisp/kernel/cleavir/debuginfo.lisp | 254 ++++++++++++++++++ src/lisp/kernel/cleavir/translate.lisp | 122 +++++---- .../kernel/cmp/compile-file-parallel.lisp | 11 +- src/llvmo/debugInfoExpose.cc | 12 + 5 files changed, 339 insertions(+), 61 deletions(-) create mode 100644 src/lisp/kernel/cleavir/debuginfo.lisp diff --git a/src/lisp/kernel/cleavir/clasp-cleavir.asd b/src/lisp/kernel/cleavir/clasp-cleavir.asd index a4853df9ca..3904c8359d 100644 --- a/src/lisp/kernel/cleavir/clasp-cleavir.asd +++ b/src/lisp/kernel/cleavir/clasp-cleavir.asd @@ -40,6 +40,7 @@ (:file "interval") (:file "type") (:file "transform") + (:file "debuginfo") (:file "translate") (:file "compile-bytecode") ;;(:file "translate-btb") ; not working yet diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp new file mode 100644 index 0000000000..c1650f8ace --- /dev/null +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -0,0 +1,254 @@ +(in-package #:clasp-cleavir) + +(defvar *generate-dwarf* nil) + +(defvar *dibuilder*) +(defvar *dbg-current-scope*) + +(defun install-compile-unit (dibuilder file) + ;; NOTE: Despite the "create" name, this function also installs the + ;; new DICompileUnit into the DIBuilder. + (llvm-sys:dibuilder/create-compile-unit + dibuilder + llvm-sys:dw-lang-c-plus-plus ; why not dw-lang-common-lisp? + file "Clasp Common Lisp" nil "-v" 1 "the-split-name.log" :full-debug + 0 t nil :dntk-default nil "" "")) + +(defun make-dibuilder (module) + (llvm-sys:make-dibuilder module)) + +(defun make-difile (pathname &key (source ";;")) + (let ((filename (file-namestring pathname)) + (directory + (namestring + (make-pathname :name nil :type nil :defaults pathname)))) + (llvm-sys:dibuilder/create-file *dibuilder* filename directory + nil source))) + +(defun add-module-di-flags (module) + ;; add the flag that defines the Dwarf Version + ;; FIXME: Why do we use a pretty old DWARF version here? + (llvm-sys:add-module-flag + module + (llvm-sys:mdnode-get (cmp:thread-local-llvm-context) + (list + (llvm-sys:value-as-metadata-get (%i32 2)) + (llvm-sys:mdstring-get + (cmp:thread-local-llvm-context) "Dwarf Version") + (llvm-sys:value-as-metadata-get + (%i32 cmp::+debug-dwarf-version+))))) + (llvm-sys:add-module-flag + module + (llvm-sys:mdnode-get (cmp:thread-local-llvm-context) + (list + (llvm-sys:value-as-metadata-get (%i32 2)) + (llvm-sys:mdstring-get + (cmp:thread-local-llvm-context) "Debug Info Version") + (llvm-sys:value-as-metadata-get + (%i32 llvm-sys:+debug-metadata-version+)))))) + +;;; Bind *dibuilder*, and if a pathname is provided, +;;; also bind *dbg-current-scope* to a new DIFile. +;;; Afterwords finalize the DIBuilder, and add debug flags to the module. +(defmacro with-debuginfo ((llvm-ir-module + &key (file nil filep) (source ";;")) + &body body) + (let ((gbody (gensym "BODY")) + (gmodule (gensym "MODULE"))) + ;; progn to error on declare expressions + `(flet ((,gbody () (progn ,@body))) + (if *generate-dwarf* + (let* ((,gmodule ,llvm-ir-module) + (*dibuilder* (make-dibuilder ,gmodule))) + (unwind-protect + ,(if filep + `(let ((*dbg-current-scope* + (make-difile ,file :source ,source))) + (install-compile-unit *dibuilder* + *dbg-current-scope*) + (,gbody)) + `(,gbody)) + (llvm-sys:dibuilder/finalize *dibuilder*) + (add-module-di-flags ,gmodule))) + (,gbody))))) + +;; Given a vrtype, create and return a metadata node describing the type +;; for debug information. (LLVM should take care of caching.) +;; FIXME: unhardcode the 64s +(defgeneric vrtype->di (vrtype)) +(defun di-zeroflags () + (core:enum-logical-or llvm-sys:diflags-enum '(llvm-sys:diflags-zero))) +(defun dispflags (&rest flags) + (core:enum-logical-or llvm-sys:dispflag-enum + (or flags '(llvm-sys:dispflag-zero)))) +(defun di-object-type () + (llvm-sys:create-basic-type *dibuilder* "T_O*" 64 + llvm-sys:+dw-ate-address+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :object))) (di-object-type)) +(defmethod vrtype->di ((vrtype (eql :boolean))) + ;; 8 is cargo-culted from what clang does for bool. + (llvm-sys:create-basic-type *dibuilder* "bool" 8 + llvm-sys:+dw-ate-boolean+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :single-float))) + (llvm-sys:create-basic-type *dibuilder* "float" 32 + llvm-sys:+dw-ate-float+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :double-float))) + (llvm-sys:create-basic-type *dibuilder* "double" 64 + llvm-sys:+dw-ate-float+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :base-char))) + (llvm-sys:create-basic-type *dibuilder* "char" 8 + llvm-sys:+dw-ate-unsigned-char+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :character))) + (llvm-sys:create-basic-type *dibuilder* "claspCharacter" 32 + llvm-sys:+dw-ate-unsigned-char+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :fixnum))) + (llvm-sys:create-basic-type *dibuilder* "fixnum" 64 + llvm-sys:+dw-ate-signed+ (di-zeroflags))) +(defmethod vrtype->di ((vrtype (eql :utfixnum))) + (llvm-sys:create-basic-type *dibuilder* "utfixnum" 64 + llvm-sys:+dw-ate-unsigned+ (di-zeroflags))) + +(defun create-di-struct-type (dibuilder name elements + &key scope (alignment 64)) + ;; These types are used by the runtime rather than being defined + ;; anywhere, so the file spec is a little dumb. + (let ((file (make-difile "-implicit-")) (lineno 0)) + (llvm-sys:create-struct-type + dibuilder scope name file lineno + ;; WARNING: This may not work in general, + ;; since e.g. a three slot structure + ;; with 32-64-32 may end up as three words. + ;; I don't know how much this matters. + (loop for ty in elements + sum (llvm-sys:get-size-in-bits ty)) + alignment (di-zeroflags) nil + (llvm-sys:get-or-create-array + dibuilder elements) + 0 nil ""))) + +(defmethod vrtype->di ((vrtype (eql :vaslist))) + (create-di-struct-type + *dibuilder* "vaslist" + (list + (llvm-sys:create-pointer-type + *dibuilder* (di-object-type) 64 64 0 "" nil) + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ (di-zeroflags))))) + +(defgeneric rtype->di (rtype)) +(defmethod rtype->di ((rtype (eql :multiple-values))) + (create-di-struct-type + *dibuilder* "T_mv" + (list + (di-object-type) + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ (di-zeroflags))))) +(defmethod rtype->di ((rtype (eql :vaslist))) + (vrtype->di rtype)) +(defmethod rtype->di ((rtype list)) + (create-di-struct-type *dibuilder* "" (mapcar #'vrtype->di rtype))) + +(defun create-di-main-function-type (ir) + (let* ((returni (bir:returni ir)) + (retrtype (if returni + (cc-bmir:rtype (bir:input returni)) + nil)) + ;; An rtype of () is void, as is a function that never returns. + ;; void is indicated as a null DIType*, which we indicate as NIL. + (ret (if retrtype (rtype->di retrtype) nil)) + (envtypes (loop repeat (cleavir-set:size (bir:environment ir)) + collect (di-object-type))) + ;; FIXME: Recomputes crap from translate + (arguments (compute-arglist (bir:lambda-list ir))) + (arg-rtypes (mapcar #'cc-bmir:rtype arguments)) + (arg-vrtypes (mapcar #'first arg-rtypes)) + (arg-ditypes (mapcar #'vrtype->di arg-vrtypes)) + (paramspec (list* ret (nconc envtypes arg-ditypes))) + (param-array + (llvm-sys:get-or-create-type-array *dibuilder* paramspec))) + (llvm-sys:create-subroutine-type *dibuilder* param-array + (di-zeroflags) 0))) + +;;; Given a source-pos-info, return a pathname, lineno, and column +;;; as values. FIXME: This integer file handle thing is really silly. +(defun spi-info (spi) + (multiple-value-bind (handle lineno column) + (core:source-pos-info-unpack spi) + (values (core:file-scope-pathname (core:file-scope handle)) + lineno column))) + +(defun create-di-main-function (ir name + &key (difile *dbg-current-scope*) + (linkage-name name)) + (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (lineno (core:source-pos-info-lineno spi))) + (llvm-sys:dibuilder/create-function + *dibuilder* *dbg-current-scope* name linkage-name difile lineno + (create-di-main-function-type ir) lineno + (di-zeroflags) (dispflags 'llvm-sys:dispflag-definition) + nil nil nil nil ""))) + +(defun create-di-nxep-type (n) + (let* ((args (make-list n :initial-element (di-object-type))) + (params (list* (rtype->di :multiple-values) args))) + (llvm-sys:create-subroutine-type + *dibuilder* + (llvm-sys:get-or-create-type-array *dibuilder* params) + (di-zeroflags) 0))) +(defun create-di-gxep-type () + (let* ((t** (llvm-sys:create-pointer-type + *dibuilder* (di-object-type) 64 64 0 "" nil)) + (size_t + (llvm-sys:create-basic-type + *dibuilder* "size_t" 64 llvm-sys:+dw-ate-unsigned+ + (di-zeroflags))) + (params (list (rtype->di :multiple-values) + (di-object-type) size_t t**))) + (llvm-sys:create-subroutine-type + *dibuilder* + (llvm-sys:get-or-create-type-array *dibuilder* params) + (di-zeroflags) 0))) + +(defun create-di-xep (ir name arity &key (difile *dbg-current-scope*) + (linkage-name name)) + (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (lineno (core:source-pos-info-lineno spi))) + (llvm-sys:dibuilder/create-function + *dibuilder* *dbg-current-scope* name linkage-name difile lineno + (if (eq arity :general-entry) + (create-di-gxep-type) + (create-di-nxep-type arity)) + lineno (di-zeroflags) (dispflags 'llvm-sys:dispflag-definition) + nil nil nil nil ""))) + +(defmacro with-di-subprogram ((function subprogram) &body body) + (let ((gfunction (gensym "FUNCTION")) (gsub (gensym "SUBPROGRAM"))) + `(let ((,gfunction ,function) (,gsub ,subprogram) + (*dbg-current-scope* nil)) + (when *generate-dwarf* + (setf *dbg-current-scope* ,gsub) + (llvm-sys:set-subprogram ,gfunction ,gsub)) + ,@body))) + +(defun get-dilocation (spi) + (multiple-value-bind (file lineno column) (spi-info spi) + (declare (ignore file)) + ;; We ignore the file because we use the local scope. + ;; The scoping doesn't fit super well with BIR, but oh well. + (llvm-sys:get-dilocation (cmp:thread-local-llvm-context) + lineno column *dbg-current-scope*))) + +;;; if SPI is nil we unset the debug location. +(defun set-instruction-source-position (spi) + (when *generate-dwarf* + (if spi + (llvm-sys:set-current-debug-location + cmp:*irbuilder* + (get-dilocation spi)) + (llvm-sys:clear-current-debug-location cmp:*irbuilder*)))) + +(defmacro with-instruction-source-position ((spi) &body body) + `(unwind-protect + (progn (set-instruction-source-position ,spi) + ,@body) + (set-instruction-source-position nil))) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 8f1afc269d..908a240d0d 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -166,16 +166,22 @@ (origin-source (bir:origin inst))) ;;; Put in source info. -#+(or) (defmethod translate-simple-instruction :around ((instruction bir:instruction) abi) (declare (ignore abi)) - (call-next-method)) -#+(or) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin instruction))) + 999902)) + (call-next-method))) (defmethod translate-terminator :around ((instruction bir:instruction) abi next) (declare (ignore abi next)) - (call-next-method)) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin instruction))) + 999903)) + (call-next-method))) (defmethod translate-terminator ((instruction bir:unreachable) abi next) @@ -1801,8 +1807,7 @@ for offset = (cmp:%closure%.offset-of[n]/t* i) when import ; skip unused fixed closure entries collect (cmp:irc-t*-load-atomic - (cmp::gen-memref-address closure-vec offset)))) - (source-pos-info (function-source-pos-info ir))) + (cmp::gen-memref-address closure-vec offset))))) ;; Tail call the real function. (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info))) (arguments @@ -1868,8 +1873,6 @@ (cmp:module-make-global-string jit-function-name "fn-name")) (llvm-function-info (find-llvm-function-info function)) (the-function (main-function llvm-function-info)) - (llvm-function-type (llvm-sys:get-function-type the-function)) - #+(or)(function-description (main-function-description llvm-function-info)) (cmp:*current-function* the-function) (entry-block (cmp:irc-basic-block-create "entry" the-function)) (*function-current-multiple-value-array-address* @@ -1878,9 +1881,7 @@ (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) (body-irbuilder (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) - (body-block (cmp:irc-basic-block-create "body")) - (source-pos-info (function-source-pos-info function)) - (lineno (core:source-pos-info-lineno source-pos-info))) + (body-block (cmp:irc-basic-block-create "body"))) #+(or)(llvm-sys:set-calling-conv the-function 'llvm-sys:fastcc) (llvm-sys:set-personality-fn the-function (cmp:irc-personality-function)) @@ -1894,14 +1895,18 @@ 'perform-optimization) (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-no-inline) (llvm-sys:add-fn-attr the-function 'llvm-sys:attribute-optimize-none)) - (cmp:irc-set-insert-point-basic-block entry-block - cmp:*irbuilder-function-alloca*) - (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (layout-main-function* the-function function - body-irbuilder body-block - abi :linkage linkage) - ;; Finish up by jumping from the entry block to the body. - (cmp:irc-br body-block)) + (with-di-subprogram (the-function + (create-di-main-function + function + (llvm-sys:get-name the-function))) + (cmp:irc-set-insert-point-basic-block entry-block + cmp:*irbuilder-function-alloca*) + (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) + (layout-main-function* the-function function + body-irbuilder body-block + abi :linkage linkage) + ;; Finish up by jumping from the entry block to the body. + (cmp:irc-br body-block))) the-function)) (defun compute-rest-alloc (cleavir-lambda-list-analysis) @@ -1925,15 +1930,16 @@ (if (literal:general-entry-placeholder-p xep-arity-function) (progn ) - (progn - (let* ((llvm-function-type (cmp:fn-prototype arity)) - (cmp:*current-function* xep-arity-function) + (with-di-subprogram (xep-arity-function + (create-di-xep + function + (llvm-sys:get-name xep-arity-function) + arity)) + (let* ((cmp:*current-function* xep-arity-function) (entry-block (cmp:irc-basic-block-create "entry" xep-arity-function)) (*function-current-multiple-value-array-address* nil) (cmp:*irbuilder-function-alloca* - (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context))) - (source-pos-info (function-source-pos-info function)) - (lineno (core:source-pos-info-lineno source-pos-info))) + (llvm-sys:make-irbuilder (cmp:thread-local-llvm-context)))) (llvm-sys:set-personality-fn xep-arity-function (cmp:irc-personality-function)) (llvm-sys:add-fn-attr2string xep-arity-function @@ -1948,19 +1954,23 @@ (cmp:irc-set-insert-point-basic-block entry-block cmp:*irbuilder-function-alloca*) (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) - (if sys:*drag-native-calls* - (cmp::irc-intrinsic "drag_native_calls")) - (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) - (calling-convention - (cmp:setup-calling-convention xep-arity-function - arity - :debug-on - (policy:policy-value - (bir:policy function) - 'save-register-args) - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis - :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) - (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi))))))))) + (with-instruction-source-position + ((ensure-origin + (origin-spi (origin-source (bir:origin function))) + 999903)) + (if sys:*drag-native-calls* + (cmp::irc-intrinsic "drag_native_calls")) + (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (calling-convention + (cmp:setup-calling-convention xep-arity-function + arity + :debug-on + (policy:policy-value + (bir:policy function) + 'save-register-args) + :cleavir-lambda-list-analysis cleavir-lambda-list-analysis + :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) + (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))) (defun maybe-note-return-cast (function) @@ -2204,13 +2214,11 @@ COMPILE-FILE will use the default *clasp-env*." (core:file-scope (core:source-pos-info-file-handle origin)))) "repl-code")))) - ;; Link the C++ intrinsics into the module (cmp::with-module (:module module) - (cmp::cmp-log "Dumping module%N") - (cmp::cmp-log-dump-module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) - (literal:with-rtv - (translate bir :linkage linkage :abi abi)) + (with-debuginfo (module :file pathname) + (literal:with-rtv + (translate bir :linkage linkage :abi abi))) (declare (ignore constants-table)) (jit-add-module-return-function cmp:*the-module* startup-shutdown-id ordered-raw-constants-list))))) @@ -2279,19 +2287,21 @@ COMPILE-FILE will use the default *clasp-env*." (let ((eof-value (gensym)) (eclector.reader:*client* cmp:*cst-client*) (cst-to-ast:*compiler* 'cl:compile-file)) - (loop - ;; Required to update the source pos info. FIXME!? - (peek-char t source-sin nil) - ;; FIXME: if :environment is provided we should probably use a different read somehow - (let* ((core:*current-source-pos-info* (cmp:compile-file-source-pos-info source-sin)) - (cst (eclector.concrete-syntax-tree:read source-sin nil eof-value))) - #+debug-monitor(sys:monitor-message "source-pos ~a" core:*current-source-pos-info*) - (if (eq cst eof-value) - (return nil) - (progn - (when *compile-print* (cmp::describe-form (cst:raw cst))) - (core:with-memory-ramp (:pattern 'gctools:ramp) - (compile-file-cst cst environment)))))))) + (with-debuginfo (cmp:*the-module* + :file (namestring cmp::*compile-file-source-debug-pathname*)) + (loop + ;; Required to update the source pos info. FIXME!? + (peek-char t source-sin nil) + ;; FIXME: if :environment is provided we should probably use a different read somehow + (let* ((core:*current-source-pos-info* (cmp:compile-file-source-pos-info source-sin)) + (cst (eclector.concrete-syntax-tree:read source-sin nil eof-value))) + #+debug-monitor(sys:monitor-message "source-pos ~a" core:*current-source-pos-info*) + (if (eq cst eof-value) + (return nil) + (progn + (when *compile-print* (cmp::describe-form (cst:raw cst))) + (core:with-memory-ramp (:pattern 'gctools:ramp) + (compile-file-cst cst environment))))))))) (defun cleavir-compile-file (input-file &rest kwargs) (let ((cmp:*cleavir-compile-file-hook* diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index a468ed5592..42f861833d 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -156,11 +156,12 @@ :optimize (when optimize #'llvm-sys:optimize-module) :optimize-level optimize-level) (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) - (with-literal-table (:id (ast-job-form-index job)) - (core:with-memory-ramp (:pattern 'gctools:ramp) - (literal:arrange-thunk-as-top-level - (clasp-cleavir-translate-bir::translate-ast - (ast-job-ast job))))) + (clasp-cleavir::with-debuginfo (module :file (namestring cmp::*compile-file-source-debug-pathname*)) + (with-literal-table (:id (ast-job-form-index job)) + (core:with-memory-ramp (:pattern 'gctools:ramp) + (literal:arrange-thunk-as-top-level + (clasp-cleavir-translate-bir::translate-ast + (ast-job-ast job)))))) (let ((startup-function (add-global-ctor-function module run-all-function :position (ast-job-form-counter job)))) ;;; (add-llvm.used module startup-function) diff --git a/src/llvmo/debugInfoExpose.cc b/src/llvmo/debugInfoExpose.cc index 5450cbb384..7f22a7d6da 100644 --- a/src/llvmo/debugInfoExpose.cc +++ b/src/llvmo/debugInfoExpose.cc @@ -312,6 +312,14 @@ CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createPointerType); CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createNullPtrType); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createNullPtrType); +CL_LAMBDA(dibuilder scope name file lineno size alignment flags derived-from elements runtime-lang vtable-holder unique-id); +CL_LISPIFY_NAME(createStructType); +CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createStructType); + +CL_LAMBDA(ditype); +CL_LISPIFY_NAME(getSizeInBits); +CL_EXTERN_DEFMETHOD(DIType_O, &llvm::DIType::getSizeInBits); + CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(createUnspecifiedParameter); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createUnspecifiedParameter); @@ -384,6 +392,10 @@ CL_DEFMETHOD DITypeRefArray_sp DIBuilder_O::getOrCreateTypeArray(core::List_sp e } else if (DINode_sp di = oCar(cur).asOrNull()) { llvm::MDNode* mdnode = di->operator llvm::MDNode*(); vector_values.push_back(mdnode); + } else if (oCar(cur).nilp()) { + // null metadata is used in a few places, such as to indicate + // a void return type in a DISubroutineType. + vector_values.push_back(nullptr); } else { SIMPLE_ERROR("Handle conversion of {} to llvm::Value*", _rep_(oCar(cur))); } From ef36513cba005db0117b8dd8b7bf3c8fe9ffd71f Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 11:24:28 -0400 Subject: [PATCH 05/37] Disable inlining & enable new DWARF generation Inlining is where the DWARF generation gets complicated. I also want to pretty much completely overhaul how inlining works. --- src/lisp/kernel/cleavir/debuginfo.lisp | 7 +++---- src/lisp/kernel/cleavir/inline.lisp | 1 + 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index c1650f8ace..32e1ff5ddd 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -1,6 +1,6 @@ (in-package #:clasp-cleavir) -(defvar *generate-dwarf* nil) +(defvar *generate-dwarf* t) (defvar *dibuilder*) (defvar *dbg-current-scope*) @@ -223,10 +223,9 @@ (defmacro with-di-subprogram ((function subprogram) &body body) (let ((gfunction (gensym "FUNCTION")) (gsub (gensym "SUBPROGRAM"))) - `(let ((,gfunction ,function) (,gsub ,subprogram) - (*dbg-current-scope* nil)) + `(let* ((,gfunction ,function) (,gsub (when *generate-dwarf* ,subprogram)) + (*dbg-current-scope* ,gsub)) (when *generate-dwarf* - (setf *dbg-current-scope* ,gsub) (llvm-sys:set-subprogram ,gfunction ,gsub)) ,@body))) diff --git a/src/lisp/kernel/cleavir/inline.lisp b/src/lisp/kernel/cleavir/inline.lisp index 7d59cca581..546c0e48a2 100644 --- a/src/lisp/kernel/cleavir/inline.lisp +++ b/src/lisp/kernel/cleavir/inline.lisp @@ -11,6 +11,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (setf cmp::*debug-create-call* nil)) +#+(or) (eval-when (:compile-toplevel :execute :load-toplevel) (setq core:*defun-inline-hook* 'defun-inline-hook)) From eca6338d41ffd98d43ca2f70005dd4e02e969739 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 13:41:26 -0400 Subject: [PATCH 06/37] integrate arguments processing code into clasp-cleavir more the *argument-out* thing is a holdover from bclasp --- src/lisp/kernel/cleavir/translate-btb.lisp | 3 +- src/lisp/kernel/cleavir/translate.lisp | 3 +- src/lisp/kernel/cmp/arguments.lisp | 41 ++++++++-------------- 3 files changed, 17 insertions(+), 30 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index e72b5ce5cf..2ed14fcb8d 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -180,8 +180,7 @@ (cmp:with-landing-pad nil (let ((ret (cmp:compile-lambda-list-code lambda-list-analysis calling-convention - arity - :argument-out #'cc::out))) + arity))) (unless ret (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) ;; Import cells. diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 908a240d0d..01c049582e 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1794,8 +1794,7 @@ (cmp:with-landing-pad nil (let ((ret (cmp:compile-lambda-list-code (cmp:xep-group-cleavir-lambda-list-analysis xep-group) calling-convention - arity - :argument-out #'out))) + arity))) (unless ret (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) ;; Import cells. diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index cfdf2eb919..75b01c854c 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -1,12 +1,5 @@ (in-package :cmp) -;; A function of two arguments, an LLVM Value and a variable. -;; The "variable" is just whatever is provided to this code -;; (so that it can work with either b or c clasp). -;; The function should put the Value into the variable, possibly generating code to do so. -;; In order to work with cclasp's SSA stuff, it must be called exactly once for each variable. -(defvar *argument-out*) - (defun compile-wrong-number-arguments-block (closure nargs min max) ;; make a new irbuilder, so as to not disturb anything (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) @@ -39,7 +32,7 @@ (dolist (req (cdr reqargs)) (let ((arg (calling-convention-vaslist.va-arg cc))) (cmp-log "(calling-convention-vaslist.va-arg cc) -> {}%N" arg) - (funcall *argument-out* arg req)))) + (clasp-cleavir::out arg req)))) ;;; Unlike the other compile-*-arguments, this one returns a value- ;;; an LLVM Value for the number of arguments remaining. @@ -74,11 +67,11 @@ switch (nargs) { (nremaining (irc-phi %size_t% npreds "nargs-remaining")) (var-phis nil) (suppliedp-phis nil)) ;; We have to do this in two loops to ensure the PHIs come before any code - ;; generated by *argument-out*. + ;; generated by OUT. (dotimes (i nopt) (push (irc-phi %t*% npreds) suppliedp-phis) (push (irc-phi %t*% npreds) var-phis)) - ;; OK _now_ argument-out + ;; OK _now_ OUT. (do* ((cur-opt opts (cdddr cur-opt)) (var (car cur-opt) (car cur-opt)) (suppliedp (cadr cur-opt) (cadr cur-opt)) @@ -87,8 +80,8 @@ switch (nargs) { (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis))) ((endp cur-opt)) - (funcall *argument-out* suppliedp-phi suppliedp) - (funcall *argument-out* var-phi var)) + (clasp-cleavir::out suppliedp-phi suppliedp) + (clasp-cleavir::out var-phi var)) (irc-br final) ;; Generate a block for each case. (do ((i nreq (1+ i))) @@ -150,7 +143,7 @@ switch (nargs) { (irc-intrinsic "cc_gatherRestArguments" (cmp:calling-convention-vaslist* calling-conv) nremaining))))) - (funcall *argument-out* rest rest-var)))) + (clasp-cleavir::out rest rest-var)))) ;;; Keyword processing is the most complicated part, unsurprisingly. #| @@ -359,8 +352,8 @@ a_p = a_p_temp; a = a_temp; (suppliedp (cadddr cur-key) (cadddr cur-key))) ((endp cur-key)) (when (or (not (eq key :allow-other-keys)) lambda-list-aokp aok-parameter-p) - (funcall *argument-out* top-param-phi var) - (funcall *argument-out* top-suppliedp-phi suppliedp))))))) + (clasp-cleavir::out top-param-phi var) + (clasp-cleavir::out top-suppliedp-phi suppliedp))))))) (defun compile-general-lambda-list-code (reqargs optargs @@ -370,10 +363,9 @@ a_p = a_p_temp; a = a_temp; keyargs allow-other-keys calling-conv - &key argument-out (safep t)) + &key (safep t)) (cmp-log "Entered compile-general-lambda-list-code%N") - (let* ((*argument-out* argument-out) - (nargs (calling-convention-nargs calling-conv)) + (let* ((nargs (calling-convention-nargs calling-conv)) (nreq (car reqargs)) (nopt (car optargs)) (nfixed (+ nreq nopt)) @@ -421,7 +413,7 @@ a_p = a_p_temp; a = a_temp; -(defun compile-only-req-and-opt-arguments (arity cleavir-lambda-list-analysis calling-conv &key argument-out (safep t)) +(defun compile-only-req-and-opt-arguments (arity cleavir-lambda-list-analysis calling-conv &key (safep t)) (multiple-value-bind (reqargs optargs) (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) (let* ((register-args (calling-convention-register-args calling-conv)) @@ -458,7 +450,7 @@ a_p = a_p_temp; a = a_temp; (compile-error-if-not-enough-arguments error-block creq nargs)) (dolist (req (cdr reqargs)) ;; we pop the register-args so that the optionals below won't use em. - (funcall argument-out (pop register-args) req))) + (clasp-cleavir::out (pop register-args) req))) ;; optional arguments. code is mostly the same as compile-optional-arguments (fixme). (if (> nopt 0) (let* ((npreds (1+ nopt)) @@ -478,8 +470,8 @@ a_p = a_p_temp; a = a_temp; (var-phis var-phis (cdr var-phis)) (suppliedp-phis suppliedp-phis (cdr suppliedp-phis))) ((endp cur-opt)) - (funcall argument-out (car suppliedp-phis) (second cur-opt)) - (funcall argument-out (car var-phis) (first cur-opt))) + (clasp-cleavir::out (car suppliedp-phis) (second cur-opt)) + (clasp-cleavir::out (car var-phis) (first cur-opt))) (irc-br after) ;; each case (dotimes (i nopt) @@ -644,7 +636,7 @@ a_p = a_p_temp; a = a_temp; ;;; translate-datum (datum) that translates a datum into an alloca in the current function ;;; (defun compile-lambda-list-code (cleavir-lambda-list-analysis calling-conv arity - &key argument-out (safep t)) + &key (safep t)) "Return T if arguments were processed and NIL if they were not" (cmp-log "about to compile-lambda-list-code cleavir-lambda-list-analysis: {}%N" cleavir-lambda-list-analysis) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) @@ -663,7 +655,6 @@ a_p = a_p_temp; a = a_temp; keyargs allow-other-keys calling-conv - :argument-out argument-out :safep safep) t ;; always successful for general lambda-list processing ) @@ -671,7 +662,6 @@ a_p = a_p_temp; a = a_temp; (may-use-only-registers cleavir-lambda-list-analysis)) (let ((result (compile-only-req-and-opt-arguments arity cleavir-lambda-list-analysis #|reqargs optargs|# calling-conv - :argument-out argument-out :safep safep))) result ; may be nil or t )) @@ -699,7 +689,6 @@ a_p = a_p_temp; a = a_temp; keyargs allow-other-keys calling-conv - :argument-out argument-out :safep safep) ) t ;; always successful when using general lambda-list processing From 24d8febc92b4c56fa161e9b2527dce6ca8b78d5d Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 13:41:42 -0400 Subject: [PATCH 07/37] arguments processor can use LOOP now since it's only loaded very late after clasp-cleavir, unlike before --- src/lisp/kernel/cmp/arguments.lisp | 83 +++++++++++------------------- 1 file changed, 31 insertions(+), 52 deletions(-) diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index 75b01c854c..9dcaef0197 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -30,9 +30,7 @@ ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. ;; cc is the calling-convention object. (dolist (req (cdr reqargs)) - (let ((arg (calling-convention-vaslist.va-arg cc))) - (cmp-log "(calling-convention-vaslist.va-arg cc) -> {}%N" arg) - (clasp-cleavir::out arg req)))) + (clasp-cleavir::out (calling-convention-vaslist.va-arg cc) req))) ;;; Unlike the other compile-*-arguments, this one returns a value- ;;; an LLVM Value for the number of arguments remaining. @@ -72,16 +70,11 @@ switch (nargs) { (push (irc-phi %t*% npreds) suppliedp-phis) (push (irc-phi %t*% npreds) var-phis)) ;; OK _now_ OUT. - (do* ((cur-opt opts (cdddr cur-opt)) - (var (car cur-opt) (car cur-opt)) - (suppliedp (cadr cur-opt) (cadr cur-opt)) - (var-phis var-phis (cdr var-phis)) - (var-phi (car var-phis) (car var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis))) - ((endp cur-opt)) - (clasp-cleavir::out suppliedp-phi suppliedp) - (clasp-cleavir::out var-phi var)) + (loop for (var suppliedp) on opts by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + do (clasp-cleavir::out suppliedp-phi suppliedp) + (clasp-cleavir::out var-phi var)) (irc-br final) ;; Generate a block for each case. (do ((i nreq (1+ i))) @@ -91,15 +84,12 @@ switch (nargs) { (irc-phi-add-incoming nremaining zero new) (irc-begin-block new) ;; Assign each optional parameter accordingly. - (do* ((var-phis var-phis (cdr var-phis)) - (var-phi (car var-phis) (car var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis)) - (j nreq (1+ j)) - (enough (< j i) (< j i))) - ((endp var-phis)) - (irc-phi-add-incoming suppliedp-phi (if enough true false) new) - (irc-phi-add-incoming var-phi (if enough (calling-convention-vaslist.va-arg calling-conv) undef) new)) + (loop for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + for j from nreq + for enough = (< j i) + do (irc-phi-add-incoming suppliedp-phi (if enough true false) new) + (irc-phi-add-incoming var-phi (if enough (calling-convention-vaslist.va-arg calling-conv) undef) new)) (irc-br assn))) ;; Default case: everything gets a value and a suppliedp=T. (irc-begin-block enough) @@ -195,10 +185,8 @@ a_p = a_p_temp; a = a_temp; (defun compile-key-arguments (keyargs lambda-list-aokp nremaining calling-conv false true) (macrolet ((do-keys ((keyword) &body body) - `(do* ((cur-key (cdr keyargs) (cddddr cur-key)) - (,keyword (car cur-key) (car cur-key))) - ((endp cur-key)) - ,@body))) + `(loop for (,keyword) on (cdr keyargs) by #'cddddr + do (progn ,@body)))) (let ((aok-parameter-p nil) allow-other-keys (nkeys (car keyargs)) @@ -266,14 +254,11 @@ a_p = a_p_temp; a = a_temp; ;; Start matching keywords (let ((key-arg (calling-convention-vaslist.va-arg calling-conv)) (value-arg (calling-convention-vaslist.va-arg calling-conv))) - (do* ((cur-key (cdr keyargs) (cddddr cur-key)) - (key (car cur-key) (car cur-key)) - (suppliedp-phis top-suppliedp-phis (cdr suppliedp-phis)) - (suppliedp-phi (car suppliedp-phis) (car suppliedp-phis))) - ((endp cur-key)) - (multiple-value-bind (new-block old-block) - (compile-one-key-test key key-arg suppliedp-phi kw-loop-continue false) - (push new-block new-blocks) (push old-block old-blocks))) + (loop for (key) on (cdr keyargs) by #'cddddr + for suppliedp-phi in top-suppliedp-phis + do (multiple-value-bind (new-block old-block) + (compile-one-key-test key key-arg suppliedp-phi kw-loop-continue false) + (push new-block new-blocks) (push old-block old-blocks))) (setf new-blocks (nreverse new-blocks) old-blocks (nreverse old-blocks)) ;; match failure - as usual, works through phi (irc-branch-to-and-begin-block unknown-kw) @@ -342,18 +327,13 @@ a_p = a_p_temp; a = a_temp; allow-other-keys bad-keyword (calling-convention-closure calling-conv)) (irc-br kw-assigns) (irc-begin-block kw-assigns))) - (do* ((top-param-phis top-param-phis (cdr top-param-phis)) - (top-param-phi (car top-param-phis) (car top-param-phis)) - (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) - (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis)) - (cur-key (cdr keyargs) (cddddr cur-key)) - (key (car cur-key) (car cur-key)) - (var (caddr cur-key) (caddr cur-key)) - (suppliedp (cadddr cur-key) (cadddr cur-key))) - ((endp cur-key)) - (when (or (not (eq key :allow-other-keys)) lambda-list-aokp aok-parameter-p) - (clasp-cleavir::out top-param-phi var) - (clasp-cleavir::out top-suppliedp-phi suppliedp))))))) + (loop for top-param-phi in top-param-phis + for top-suppliedp-phi in top-suppliedp-phis + for (key _ var suppliedp) on (cdr keyargs) by #'cddddr + when (or (not (eq key :allow-other-keys)) + lambda-list-aokp aok-parameter-p) + do (clasp-cleavir::out top-param-phi var) + (clasp-cleavir::out top-suppliedp-phi suppliedp)))))) (defun compile-general-lambda-list-code (reqargs optargs @@ -466,12 +446,11 @@ a_p = a_p_temp; a = a_temp; (dotimes (i nopt) (push (irc-phi %t*% npreds) var-phis) (push (irc-phi %t*% npreds) suppliedp-phis)) - (do ((cur-opt (cdr optargs) (cdddr cur-opt)) - (var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis))) - ((endp cur-opt)) - (clasp-cleavir::out (car suppliedp-phis) (second cur-opt)) - (clasp-cleavir::out (car var-phis) (first cur-opt))) + (loop for (var suppliedp) on (cdr optargs) by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + do (clasp-cleavir::out suppliedp-phi suppliedp) + (clasp-cleavir::out var-phi var)) (irc-br after) ;; each case (dotimes (i nopt) From 6a4a437bc65852f91af30b65bd1fc93ffdac3b10 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 15:23:32 -0400 Subject: [PATCH 08/37] Delete unused calling convention slot --- src/lisp/kernel/cleavir/translate-btb.lisp | 1 - src/lisp/kernel/cleavir/translate.lisp | 1 - src/lisp/kernel/cmp/arguments.lisp | 5 ++--- src/lisp/kernel/cmp/cmpintrinsics.lisp | 11 +---------- 4 files changed, 3 insertions(+), 15 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index 2ed14fcb8d..5dddee295f 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -254,7 +254,6 @@ (policy:policy-value (bir:policy ir) 'save-register-args) - :cleavir-lambda-list-analysis lambda-list-analysis :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) (layout-xep-function* xep arity ir lambda-list-analysis calling-convention))))) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 01c049582e..0b0fb47023 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1967,7 +1967,6 @@ (policy:policy-value (bir:policy function) 'save-register-args) - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))) diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index 9dcaef0197..d2686d0c42 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -679,9 +679,8 @@ a_p = a_p_temp; a = a_temp; ;; Setup the calling convention ;; (defun setup-calling-convention (llvm-function arity - &key debug-on rest-alloc cleavir-lambda-list-analysis) + &key debug-on rest-alloc) (initialize-calling-convention llvm-function arity :debug-on debug-on - :rest-alloc rest-alloc - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis)) + :rest-alloc rest-alloc)) diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index 04d41f36a7..883c6748b5 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -627,26 +627,19 @@ Boehm and MPS use a single pointer" nargs register-args ; The arguments that were passed in registers vaslist* ; The address of the vaslist, or NIL - cleavir-lambda-list-analysis ; analysis of cleavir-lambda-list rest-alloc ; whether we can dx or ignore a &rest argument ) ;; Parse the function arguments into a calling-convention -(defun initialize-calling-convention (llvm-function arity &key debug-on cleavir-lambda-list-analysis rest-alloc) - (cmp-log "llvm-function: {}%N" llvm-function) +(defun initialize-calling-convention (llvm-function arity &key debug-on rest-alloc) (let ((arguments (llvm-sys:get-argument-list llvm-function))) - (cmp-log "llvm-function arguments: {}%N" (llvm-sys:get-argument-list llvm-function)) - (cmp-log "llvm-function isVarArg: {}%N" (llvm-sys:is-var-arg llvm-function)) (let ((register-save-area* (when debug-on (alloca-register-save-area arity :label "register-save-area"))) (closure (first arguments))) - (cmp-log "A%N") (unless (first arguments) (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) - (cmp-log "A%N") (cond ((eq arity :general-entry) - (cmp-log "B%N") (let* ((nargs (second arguments)) (args (third arguments)) (vaslist* (alloca-vaslist))) @@ -655,7 +648,6 @@ Boehm and MPS use a single pointer" (make-calling-convention :closure closure :nargs nargs :vaslist* vaslist* - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis :rest-alloc rest-alloc))) (t (let ((nargs (length (cdr arguments))) @@ -664,7 +656,6 @@ Boehm and MPS use a single pointer" (make-calling-convention :closure closure :nargs (jit-constant-i64 nargs) :register-args register-args - :cleavir-lambda-list-analysis cleavir-lambda-list-analysis :rest-alloc rest-alloc))))))) ;;; From 3326d487c3509632212bb416f3764bf0bb4e6523 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 16:46:06 -0400 Subject: [PATCH 09/37] Allow wrong-number-of-arguments to have just a function's name I want to use the argument processor for inline bodies, so there may not actually be a closure. --- src/lisp/kernel/clos/conditions.lisp | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/lisp/kernel/clos/conditions.lisp b/src/lisp/kernel/clos/conditions.lisp index b37e1c277d..7351074189 100644 --- a/src/lisp/kernel/clos/conditions.lisp +++ b/src/lisp/kernel/clos/conditions.lisp @@ -1081,8 +1081,11 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (cell-error-name condition))))) (define-condition core:wrong-number-of-arguments (program-error) - (;; may be NIL if this is called from the interpreter and we don't know anything - ;; (KLUDGE, FIXME?) + (;; Some kind of name for the called function, or NIL if nothing is available. + ;; Note that this is not necessarily a legal function name. E.g. it could be + ;; a lambda expression, or an (FLET FOO) kind of name. + ;; It can also be a function itself rather than a name, because that's how + ;; it used to work. (called-function :initform nil :initarg :called-function :reader called-function) (given-nargs :initarg :given-nargs :reader given-nargs) ;; also may be NIL, same reason (KLUDGE, FIXME?) @@ -1093,10 +1096,11 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (let* ((min (min-nargs condition)) (max (max-nargs condition)) (function (called-function condition)) - (name (and function (core:function-name function))) - (dname (if (eq name 'cl:lambda) "anonymous function" name))) + (fname (if (functionp function) + (core:function-name function) + function))) (format stream "~@[Calling ~a - ~]Got ~d arguments, but expected ~@?" - dname (given-nargs condition) + fname (given-nargs condition) (cond ((null max) "at least ~d") ((null min) "at most ~*~d") ;; I think "exactly 0" is better than "at most 0", thus duplication @@ -1129,9 +1133,12 @@ The conflict resolver must be one of ~s" chosen-symbol candidates)) (define-condition core:odd-keywords (program-error) ((%called-function :initarg :called-function :reader called-function)) (:report (lambda (condition stream) - (format stream "Odd number of keyword arguments~:[~; for ~s~]." - (called-function condition) - (core:function-name (called-function condition)))))) + (let* ((function (called-function condition)) + (fname (if (functionp function) + (core:function-name function) + function))) + (format stream "Odd number of keyword arguments~@[ for ~s~]." + fname))))) (define-condition core:unrecognized-keyword-argument-error (program-error) ((called-function :initarg :called-function :reader called-function :initform nil) From cb6ed186bec92c25fb03d6ca768c2a587b16f630 Mon Sep 17 00:00:00 2001 From: Bike Date: Tue, 30 Apr 2024 22:41:46 -0400 Subject: [PATCH 10/37] Move register-save-area handling into translate It's not really part of argument parsing, so it doesn't belong in the "calling convention" code at all. --- src/lisp/kernel/cleavir/translate-btb.lisp | 10 +--- src/lisp/kernel/cleavir/translate.lisp | 44 +++++++++++--- src/lisp/kernel/cmp/arguments.lisp | 12 ---- src/lisp/kernel/cmp/cmpexports.lisp | 2 +- src/lisp/kernel/cmp/cmpintrinsics.lisp | 70 +++++++--------------- src/lisp/kernel/cmp/cmpir.lisp | 2 +- 6 files changed, 63 insertions(+), 77 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index 5dddee295f..3bbea77fbb 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -248,13 +248,9 @@ (when sys:*drag-native-calls* (cmp::irc-intrinsic "drag_native_calls")) (let ((calling-convention - (cmp:setup-calling-convention xep - arity - :debug-on - (policy:policy-value - (bir:policy ir) - 'save-register-args) - :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) + (cmp:initialize-calling-convention xep + arity + :rest-alloc (cc::compute-rest-alloc lambda-list-analysis)))) (layout-xep-function* xep arity ir lambda-list-analysis calling-convention))))) (defun layout-xep-group (function lambda-name abi) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 0b0fb47023..4a7d10a0eb 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1959,17 +1959,45 @@ 999903)) (if sys:*drag-native-calls* (cmp::irc-intrinsic "drag_native_calls")) - (let* ((cleavir-lambda-list-analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (let* ((cleavir-lambda-list-analysis + (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (rest-alloc + (compute-rest-alloc cleavir-lambda-list-analysis)) (calling-convention - (cmp:setup-calling-convention xep-arity-function - arity - :debug-on - (policy:policy-value - (bir:policy function) - 'save-register-args) - :rest-alloc (compute-rest-alloc cleavir-lambda-list-analysis)))) + (cmp:initialize-calling-convention + xep-arity-function arity + :rest-alloc rest-alloc))) + (when (policy:policy-value (bir:policy function) + 'save-register-args) + (save-registers xep-arity-function arity + (cmp:alloca-register-save-area arity))) (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))) +;;; Generate code to dump arguments ("registers") to a "register save area" in +;;; memory, where they can be read by the debugger even in the face of +;;; heavy optimization. +(defun save-registers (function arity rsa) + (let* ((arguments (llvm-sys:get-argument-list function)) + (nargs (length arguments)) + (rsa-type (llvm-sys:array-type-get cmp:%t*% nargs))) + (flet ((spill-reg (index reg name) + (cmp:irc-store reg + (cmp:irc-typed-gep rsa-type rsa (list 0 index) name) + ;; volatile, so optimizations don't remove it. + t))) + (cond ((eq arity :general-entry) + ;; special cased, since we pun the non-lispobj arguments. + (destructuring-bind (closure nargs args) arguments + (spill-reg 0 closure "rsa-closure") + (spill-reg 1 (cmp:irc-int-to-ptr nargs cmp:%i8*% "nargs-i8*") + "rsa-nargs") + (spill-reg 2 (cmp:irc-bit-cast args cmp:%i8*% "reg-i8*") "rsa-args"))) + (t + (loop for i from 0 + for arg in arguments + for name in '("rsa-closure" "rsa-arg0" "rsa-arg1" "rsa-arg2" + "rsa-arg3" "rsa-arg4" "rsa-arg5" "rsa-arg6") + do (spill-reg i arg name))))))) (defun maybe-note-return-cast (function) (let ((returni (bir:returni function))) diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index d2686d0c42..e326c58bfb 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -672,15 +672,3 @@ a_p = a_p_temp; a = a_temp; ) t ;; always successful when using general lambda-list processing )))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Setup the calling convention -;; -(defun setup-calling-convention (llvm-function arity - &key debug-on rest-alloc) - (initialize-calling-convention llvm-function - arity - :debug-on debug-on - :rest-alloc rest-alloc)) diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp index fbf1e5a6bb..d6d2b533fc 100644 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ b/src/lisp/kernel/cmp/cmpexports.lisp @@ -191,6 +191,7 @@ alloca-vaslist alloca-temp-values alloca-arguments + alloca-register-save-area irc-and irc-or irc-xor @@ -307,7 +308,6 @@ jit-constant-unique-string-ptr module-make-global-string make-boot-function-global-variable - setup-calling-convention initialize-calling-convention ensure-cleavir-lambda-list ensure-cleavir-lambda-list-analysis diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index 883c6748b5..fdcf0c3f69 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -632,31 +632,28 @@ Boehm and MPS use a single pointer" ;; Parse the function arguments into a calling-convention -(defun initialize-calling-convention (llvm-function arity &key debug-on rest-alloc) - (let ((arguments (llvm-sys:get-argument-list llvm-function))) - (let ((register-save-area* (when debug-on (alloca-register-save-area arity :label "register-save-area"))) - (closure (first arguments))) - (unless (first arguments) - (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) - (cond - ((eq arity :general-entry) - (let* ((nargs (second arguments)) - (args (third arguments)) - (vaslist* (alloca-vaslist))) - (vaslist-start vaslist* nargs args) - (maybe-spill-to-register-save-area arity register-save-area* (list closure nargs args)) - (make-calling-convention :closure closure - :nargs nargs - :vaslist* vaslist* - :rest-alloc rest-alloc))) - (t - (let ((nargs (length (cdr arguments))) - (register-args (cdr arguments))) - (maybe-spill-to-register-save-area arity register-save-area* (list* closure register-args)) - (make-calling-convention :closure closure - :nargs (jit-constant-i64 nargs) - :register-args register-args - :rest-alloc rest-alloc))))))) +(defun initialize-calling-convention (llvm-function arity &key rest-alloc) + (let* ((arguments (llvm-sys:get-argument-list llvm-function)) + (closure (first arguments))) + (unless closure + (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) + (cond + ((eq arity :general-entry) + (let* ((nargs (second arguments)) + (args (third arguments)) + (vaslist* (alloca-vaslist))) + (vaslist-start vaslist* nargs args) + (make-calling-convention :closure closure + :nargs nargs + :vaslist* vaslist* + :rest-alloc rest-alloc))) + (t + (let ((nargs (length (cdr arguments))) + (register-args (cdr arguments))) + (make-calling-convention :closure closure + :nargs (jit-constant-i64 nargs) + :register-args register-args + :rest-alloc rest-alloc)))))) ;;; ;;; Read the next argument from the vaslist @@ -683,29 +680,6 @@ Boehm and MPS use a single pointer" (error "Arity is too high -add support for this ~a" arity)) (t (error "fn-prototype-names Illegal arity ~a" arity)))) -;; (Maybe) generate code to store registers in memory. Return value unspecified. -(defun maybe-spill-to-register-save-area (arity register-save-area* registers) - (cmp-log "maybe-spill-to-register-save-area register-save-area* -> {}%N" register-save-area*) - (cmp-log "maybe-spill-to-register-save-area registers -> {}%N" registers) - (when register-save-area* - (let ((words (irc-arity-info arity))) - (flet ((spill-reg (idx reg addr-name) - (let ((addr (irc-typed-gep (llvm-sys:array-type-get %t*% words) register-save-area* (list 0 idx) addr-name)) - (reg-i8* (cond - ((llvm-sys:type-equal (llvm-sys:get-type reg) %i64%) - (irc-int-to-ptr reg %i8*% "nargs-i8*")) - (t - (irc-bit-cast reg %i8*% "reg-i8*"))))) - (irc-store reg-i8* addr t) - addr))) - (let* ((names (if (eq arity :general-entry) - (list "rsa-closure" "rsa-nargs" "rsa-args") - (list "rsa-closure" "rsa-arg0" "rsa-arg1" "rsa-arg2" "rsa-arg3" "rsa-arg4" "rsa-arg5" "rsa-arg6" "rsa-arg7"))) - (idx 0)) - (mapc (lambda (reg name) - (spill-reg idx reg name) - (incf idx)) - registers names)))))) ;;; This is the normal C-style prototype for a function (define-symbol-macro %opaque-fn-prototype*% %i8*%) diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cmp/cmpir.lisp index 747f235eb6..5d0819d0d4 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cmp/cmpir.lisp @@ -1157,7 +1157,7 @@ function-description - for debugging." (defun alloca-arguments (size &optional (label "callargs")) (llvm-sys:create-alloca *irbuilder-function-alloca* (llvm-sys:array-type-get %t*% size) (jit-constant-i64 1) label)) -(defun alloca-register-save-area (arity &key (irbuilder *irbuilder-function-alloca*) (label "vaslist")) +(defun alloca-register-save-area (arity &key (irbuilder *irbuilder-function-alloca*) (label "register-save-area")) "Alloca space for a register save area, and keep it in the stack map." (with-irbuilder (irbuilder) (multiple-value-bind (words index) From 4571a70e27c6d1edde064247c237a8fe3a847833 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 1 May 2024 10:47:07 -0400 Subject: [PATCH 11/37] Make the argument processor for-effect I don't think it has been able to return false for years, and I'm not sure why it ever would. --- src/lisp/kernel/cleavir/translate-btb.lisp | 7 ++----- src/lisp/kernel/cleavir/translate.lisp | 8 +++----- src/lisp/kernel/cmp/arguments.lisp | 23 ++++++---------------- 3 files changed, 11 insertions(+), 27 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index 3bbea77fbb..2e57fe58ea 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -178,11 +178,8 @@ (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) ;; Parse lambda list. (cmp:with-landing-pad nil - (let ((ret (cmp:compile-lambda-list-code lambda-list-analysis - calling-convention - arity))) - (unless ret - (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) + (cmp:compile-lambda-list-code lambda-list-analysis + calling-convention arity) ;; Import cells. (let* ((closure-vec (first (llvm-sys:get-argument-list xep))) (llvm-function-info (cc::find-llvm-function-info ir)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 4a7d10a0eb..22aec5d95c 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1792,11 +1792,9 @@ (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) ;; Parse lambda list. (cmp:with-landing-pad nil - (let ((ret (cmp:compile-lambda-list-code (cmp:xep-group-cleavir-lambda-list-analysis xep-group) - calling-convention - arity))) - (unless ret - (error "cmp:compile-lambda-list-code returned NIL which means this is not a function that should be generated"))) + (cmp:compile-lambda-list-code + (cmp:xep-group-cleavir-lambda-list-analysis xep-group) + calling-convention arity) ;; Import cells. (let* ((closure-vec (first (llvm-sys:get-argument-list the-function))) (llvm-function-info (find-llvm-function-info ir)) diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index e326c58bfb..7fa8cf4075 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -490,8 +490,7 @@ a_p = a_p_temp; a = a_temp; (irc-begin-block after))) ;; no optional arguments, so not much to do (when safep - (compile-error-if-too-many-arguments error-block cmax nargs)))) - t))) + (compile-error-if-too-many-arguments error-block cmax nargs))))))) (defun req-opt-only-p (cleavir-lambda-list) (let ((nreq 0) (nopt 0) (req-opt-only t) @@ -608,12 +607,7 @@ a_p = a_p_temp; a = a_temp; (and (<= +entry-point-arity-begin+ (+ nreq nopt)) (< (+ nreq nopt) +entry-point-arity-end+))))) -;;; compile-lambda-list-code -;;; you must provide the following lambdas -;;; alloca-size_t (label) that allocas a size_t slot in the current function -;;; alloca-vaslist (label) that allocas a vaslist slot in the current function -;;; translate-datum (datum) that translates a datum into an alloca in the current function -;;; +;;; Main entry point. Called for effect. (defun compile-lambda-list-code (cleavir-lambda-list-analysis calling-conv arity &key (safep t)) "Return T if arguments were processed and NIL if they were not" @@ -639,11 +633,9 @@ a_p = a_p_temp; a = a_temp; ) ((and (fixnump arity) (may-use-only-registers cleavir-lambda-list-analysis)) - (let ((result (compile-only-req-and-opt-arguments arity cleavir-lambda-list-analysis #|reqargs optargs|# - calling-conv - :safep safep))) - result ; may be nil or t - )) + (compile-only-req-and-opt-arguments arity cleavir-lambda-list-analysis + calling-conv + :safep safep)) (t (let* ((register-args (calling-convention-register-args calling-conv)) (nargs (length register-args)) (arg-buffer (if (= nargs 0) @@ -668,7 +660,4 @@ a_p = a_p_temp; a = a_temp; keyargs allow-other-keys calling-conv - :safep safep) - ) - t ;; always successful when using general lambda-list processing - )))) + :safep safep)))))) From 1af73df6f909ce8313dd901a0b2547a94f29f2fb Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 1 May 2024 12:25:29 -0400 Subject: [PATCH 12/37] reorient optional argument processor to not compute nremaining I'm going to have all these return a list of arguments instead, so returning the number remaining is no good. --- src/lisp/kernel/cmp/arguments.lisp | 70 +++++++++++++---------------- src/lisp/kernel/cmp/primitives.lisp | 1 + 2 files changed, 33 insertions(+), 38 deletions(-) diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cmp/arguments.lisp index 7fa8cf4075..bb9230625d 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cmp/arguments.lisp @@ -32,19 +32,16 @@ (dolist (req (cdr reqargs)) (clasp-cleavir::out (calling-convention-vaslist.va-arg cc) req))) -;;; Unlike the other compile-*-arguments, this one returns a value- -;;; an LLVM Value for the number of arguments remaining. (defun compile-optional-arguments (optargs nreq calling-conv false true) ;; optargs is (# var suppliedp default ...) - ;; We basically generate a switch, but also return the number of arguments remaining - ;; (or zero if that's negative). + ;; We basically generate a switch. ;; For (&optional a b) for example, #| size_t nargs_remaining; switch (nargs) { - case 0: nargs_remaining = 0; a = [nil]; a_p = [nil]; b = [nil]; b_p = [nil]; break; - case 1: nargs_remaining = 0; a = va_arg(); a_p = [t]; b = [nil]; b_p = [nil]; break; - default: nargs_remaining = nargs - 2; a = va_arg(); a_p = [t]; b = va_arg(); b_p = [t]; break; + case 0: a = [nil]; a_p = [nil]; b = [nil]; b_p = [nil]; break; + case 1: a = va_arg(); a_p = [t]; b = [nil]; b_p = [nil]; break; + default: a = va_arg(); a_p = [t]; b = va_arg(); b_p = [t]; break; } |# ;; All these assignments are done with phi so it's a bit more confusing to follow, unfortunately. @@ -56,14 +53,12 @@ switch (nargs) { (undef (irc-undef-value-get %t*%)) (sw (irc-switch nargs enough nopt)) (assn (irc-basic-block-create "optional-assignments")) - (final (irc-basic-block-create "done-parsing-optionals")) - (zero (irc-size_t 0))) + (final (irc-basic-block-create "done-parsing-optionals"))) ;; We generate the assignments first, although they occur last. ;; It's just a bit more convenient to do that way. (irc-begin-block assn) - (let* ((npreds (1+ nopt)) - (nremaining (irc-phi %size_t% npreds "nargs-remaining")) - (var-phis nil) (suppliedp-phis nil)) + (let ((npreds (1+ nopt)) + (var-phis nil) (suppliedp-phis nil)) ;; We have to do this in two loops to ensure the PHIs come before any code ;; generated by OUT. (dotimes (i nopt) @@ -81,7 +76,6 @@ switch (nargs) { ((= i nfixed)) (let ((new (irc-basic-block-create (core:fmt nil "supplied-{}-arguments" i)))) (llvm-sys:add-case sw (irc-size_t i) new) - (irc-phi-add-incoming nremaining zero new) (irc-begin-block new) ;; Assign each optional parameter accordingly. (loop for var-phi in var-phis @@ -93,15 +87,13 @@ switch (nargs) { (irc-br assn))) ;; Default case: everything gets a value and a suppliedp=T. (irc-begin-block enough) - (irc-phi-add-incoming nremaining (irc-sub nargs (irc-size_t nfixed)) enough) (dolist (suppliedp-phi suppliedp-phis) (irc-phi-add-incoming suppliedp-phi true enough)) (dolist (var-phi var-phis) (irc-phi-add-incoming var-phi (calling-convention-vaslist.va-arg calling-conv) enough)) (irc-br assn) ;; ready to generate more code - (irc-begin-block final) - nremaining))) + (irc-begin-block final)))) (defun compile-rest-argument (rest-var varest-p nremaining calling-conv) (cmp:irc-branch-to-and-begin-block (cmp:irc-basic-block-create "process-rest-argument")) @@ -357,38 +349,40 @@ a_p = a_p_temp; a = a_temp; (when safep (compile-wrong-number-arguments-block (calling-convention-closure calling-conv) - nargs creq cmax)))) + nargs creq cmax))) + ;; NOTE: Sometimes we don't actually need these. + ;; We could save miniscule time by not generating. + (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) (unless (zerop nreq) (when safep (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) (compile-required-arguments reqargs calling-conv)) - (let (;; NOTE: Sometimes we don't actually need these. - ;; We could save miniscule time by not generating. - (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) - (if (or rest-var key-flag) - ;; We have &key and/or &rest, so parse with that expectation. - ;; Specifically, we have to get a variable for how many arguments are left after &optional. - (let ((nremaining - (if (zerop nopt) - ;; With no optional arguments it's trivial. - (irc-sub nargs creq "nremaining") - ;; Otherwise - (compile-optional-arguments optargs nreq calling-conv iNIL iT)))) + (unless (zerop nopt) + (compile-optional-arguments optargs nreq calling-conv iNIL iT)) + (if (or rest-var key-flag) + ;; We have &key and/or &rest, so parse with that expectation. + ;; Specifically, we have to get a variable for how many arguments are left after &optional. + (let ((nremaining + (if (zerop nopt) + ;; With no optional arguments it's trivial. + (irc-sub nargs creq "nremaining") + ;; Otherwise we need nargs - nfixed, clamped to min 0. + ;; (Since nfixed > nargs is possible.) + ;; We used to have compile-optional-arguments return + ;; the number of remaining arguments, but that's a bit + ;; of pointless code for the rare case that we have + ;; both &optional and &rest/&key. + (irc-intrinsic "llvm.usub.sat.i64" nargs + (irc-size_t nfixed))))) ;; Note that we don't need to check for too many arguments here. (when rest-var (compile-rest-argument rest-var varest-p nremaining calling-conv)) (when key-flag (compile-key-arguments keyargs (or allow-other-keys (not safep)) nremaining calling-conv iNIL iT))) - ;; We don't have &key or &rest, but we might still have &optional. - (progn - (unless (zerop nopt) - ;; Return value of compile-optional-arguments is unneeded- - ;; we could use it in the error check to save a subtraction, though. - (compile-optional-arguments optargs nreq calling-conv iNIL iT)) - (when safep - (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) - (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))))) + (when safep + (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) + (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))) diff --git a/src/lisp/kernel/cmp/primitives.lisp b/src/lisp/kernel/cmp/primitives.lisp index cede70d7c5..d0dda96416 100644 --- a/src/lisp/kernel/cmp/primitives.lisp +++ b/src/lisp/kernel/cmp/primitives.lisp @@ -131,6 +131,7 @@ (primitive "llvm.sadd.with.overflow.i64" :{i64.i1} (list :i64 :i64)) (primitive "llvm.ssub.with.overflow.i32" :{i32.i1} (list :i32 :i32)) (primitive "llvm.ssub.with.overflow.i64" :{i64.i1} (list :i64 :i64)) + (primitive "llvm.usub.sat.i64" :i64 (list :i64 :i64)) (primitive "llvm.ctpop.i64" :i64 (list :i64)) ;; NOTE: FP primitives may signal a floating point exception but this ;; is not the same as raising an exception. I think. FIXME: Check. From a365f50b25d438923d61fe41780c8d230a00d0ab Mon Sep 17 00:00:00 2001 From: Bike Date: Thu, 2 May 2024 08:43:03 -0400 Subject: [PATCH 13/37] Integrate argument processing into clasp-cleavir and remove the confusing calling-convention stuff. And unify the code so that the required-and-optionals case works efficiently without having its own code. Moving towards being able to process arguments in the middle of a function (for an inline call). --- src/lisp/cscript.lisp | 1 - .../kernel/{cmp => cleavir}/arguments.lisp | 483 +++++++----------- src/lisp/kernel/cleavir/clasp-cleavir.asd | 1 + src/lisp/kernel/cleavir/translate.lisp | 57 +-- src/lisp/kernel/cmp/cmpexports.lisp | 7 - src/lisp/kernel/cmp/cmpintrinsics.lisp | 46 -- src/lisp/kernel/cmp/cmpir.lisp | 16 +- src/lisp/kernel/cmp/primitives.lisp | 6 +- src/lisp/kernel/cmp/workbench.lisp | 7 +- src/llvmo/intrinsics.cc | 6 +- src/llvmo/link_intrinsics.cc | 10 +- src/llvmo/llvmoExpose.cc | 4 +- 12 files changed, 236 insertions(+), 408 deletions(-) rename src/lisp/kernel/{cmp => cleavir}/arguments.lisp (52%) diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp index d289f2f6e1..8e8b78be81 100644 --- a/src/lisp/cscript.lisp +++ b/src/lisp/cscript.lisp @@ -146,7 +146,6 @@ #~"kernel/stage/base/1-end.lisp" #~"kernel/stage/base/2-begin.lisp" :clasp-cleavir - #~"kernel/cmp/arguments.lisp" #~"kernel/lsp/queue.lisp" ;; cclasp sources #~"kernel/lsp/generated-encodings.lisp" #~"kernel/lsp/process.lisp" diff --git a/src/lisp/kernel/cmp/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp similarity index 52% rename from src/lisp/kernel/cmp/arguments.lisp rename to src/lisp/kernel/cleavir/arguments.lisp index bb9230625d..e7f6e7373d 100644 --- a/src/lisp/kernel/cmp/arguments.lisp +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -1,13 +1,59 @@ (in-package :cmp) -(defun compile-wrong-number-arguments-block (closure nargs min max) +(defgeneric xep-nargs (arguments)) + +(defclass xep-arguments () ()) +(defclass general-xep-arguments (xep-arguments) + ((%array :initarg :array :reader xep-array) + (%nargs :initarg :nargs :reader xep-nargs))) +(defclass fixed-xep-arguments (xep-arguments) + ((%arguments :initarg :arguments :reader xep-arguments))) + +(defmethod xep-nargs ((arguments fixed-xep-arguments)) + (irc-size_t (length (xep-arguments arguments)))) + +;;; Generate code to get the nth argument (i.e. an LLVM Value) and return it. +;;; n is a constant (i.e. a Lisp integer). +(defgeneric nth-arg (arguments n)) +(defmethod nth-arg ((args general-xep-arguments) n) + (irc-t*-load (irc-typed-gep (llvm-sys:array-type-get %t*% 0) + (xep-array args) (list 0 n) "arg*"))) +(defmethod nth-arg ((args fixed-xep-arguments) n) + (nth n (xep-arguments args))) + +;;; Generate code to get the arguments starting with the nth as an array. +;;; n is a constant (i.e. a Lisp integer). +(defgeneric remaining-args (args n)) +(defmethod remaining-args ((args general-xep-arguments) n) + ;; Note that n (a constant) must be less than nargs (a variable) for the + ;; GEP to be a valid pointer. We don't load from it in that case, but we + ;; still don't want to use an inbounds GEP because poison is bad. + (irc-const-gep1-64 %t**% (xep-array args) n "args")) +(defmethod remaining-args ((args fixed-xep-arguments) n) + ;; Here we have to actually allocate, and then fill it up. + ;; Since we have a constant nargs and constant n, the size of the + ;; allocation is fixed. + (let* ((vals (xep-arguments args)) + (size (- (length vals) n))) + (if (<= size 0) + (llvm-sys:constant-pointer-null-get %t**%) + (let ((res (alloca %t*% size))) + ;; Fill it up. + (loop for arg in (nthcdr n vals) + for i from 0 + for addr = (irc-typed-gep (llvm-sys:array-type-get %t*% 0) + res (list i)) + do (irc-store arg addr)) + res)))) + +(defun compile-wrong-number-arguments-block (fname nargs min max) ;; make a new irbuilder, so as to not disturb anything (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) (let ((errorb (irc-basic-block-create "wrong-num-args"))) (irc-begin-block errorb) (irc-intrinsic "cc_wrong_number_of_arguments" ;; We use low max to indicate no upper limit. - closure nargs min (or max (irc-size_t 0))) + fname nargs min (or max (irc-size_t 0))) (irc-unreachable) errorb))) @@ -26,13 +72,16 @@ (irc-begin-block cont-block))) ;; Generate code to bind the required arguments. -(defun compile-required-arguments (reqargs cc) +(defun compile-required-arguments (xepargs reqargs) ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. - ;; cc is the calling-convention object. - (dolist (req (cdr reqargs)) - (clasp-cleavir::out (calling-convention-vaslist.va-arg cc) req))) + (loop for i from 0 + for req in (cdr reqargs) + do (clasp-cleavir::out (nth-arg xepargs i) req))) -(defun compile-optional-arguments (optargs nreq calling-conv false true) +(defgeneric compile-optional-arguments (xepargs optargs nreq false true)) +(defmethod compile-optional-arguments ((xepargs general-xep-arguments) + optargs nreq false true) + ;; General case: variadic call. ;; optargs is (# var suppliedp default ...) ;; We basically generate a switch. ;; For (&optional a b) for example, @@ -45,7 +94,7 @@ switch (nargs) { } |# ;; All these assignments are done with phi so it's a bit more confusing to follow, unfortunately. - (let* ((nargs (calling-convention-nargs calling-conv)) + (let* ((nargs (xep-nargs xepargs)) (nopt (first optargs)) (nfixed (+ nopt nreq)) (opts (rest optargs)) @@ -83,102 +132,108 @@ switch (nargs) { for j from nreq for enough = (< j i) do (irc-phi-add-incoming suppliedp-phi (if enough true false) new) - (irc-phi-add-incoming var-phi (if enough (calling-convention-vaslist.va-arg calling-conv) undef) new)) + (irc-phi-add-incoming var-phi (if enough (nth-arg xepargs i) undef) new)) (irc-br assn))) ;; Default case: everything gets a value and a suppliedp=T. (irc-begin-block enough) (dolist (suppliedp-phi suppliedp-phis) (irc-phi-add-incoming suppliedp-phi true enough)) - (dolist (var-phi var-phis) - (irc-phi-add-incoming var-phi (calling-convention-vaslist.va-arg calling-conv) enough)) + (loop for var-phi in var-phis + for i from nreq + do (irc-phi-add-incoming var-phi (nth-arg xepargs i) enough)) (irc-br assn) ;; ready to generate more code (irc-begin-block final)))) -(defun compile-rest-argument (rest-var varest-p nremaining calling-conv) +(defmethod compile-optional-arguments ((xepargs fixed-xep-arguments) + optargs nreq false true) + ;; Specific case: Argcount is known. Optional processing is basically + ;; trivial in this circumstance. + (loop with args = (nthcdr nreq (xep-arguments xepargs)) + with undef = (irc-undef-value-get %t*%) + for (var suppliedp) on (rest optargs) by #'cdddr + for arg = (pop args) + do (multiple-value-bind (val sp) + (if (null arg) ; out of arguments + (values undef false) + (values arg true)) + (clasp-cleavir::out sp suppliedp) + (clasp-cleavir::out val var)))) + +(defun compile-rest-argument (rest-var varest-p rest-alloc args nremaining) (cmp:irc-branch-to-and-begin-block (cmp:irc-basic-block-create "process-rest-argument")) - (when rest-var - (let* ((rest-alloc (calling-convention-rest-alloc calling-conv)) - (rest (cond - ((eq rest-alloc 'ignore) - ;; &rest variable is ignored- allocate nothing - (irc-undef-value-get %t*%)) - ((eq rest-alloc 'dynamic-extent) - ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. - (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) - (irc-intrinsic "cc_gatherDynamicExtentRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining - (irc-bit-cast rrest %t**%)))) - (varest-p - #+(or) - (irc-tag-vaslist (cmp:calling-convention-vaslist* calling-conv) - "rest") - ;;#+(or) - (let ((temp-vaslist (alloca-vaslist :label "rest"))) - (irc-intrinsic "cc_gatherVaRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining - temp-vaslist))) - (t - ;; general case- heap allocation - (irc-intrinsic "cc_gatherRestArguments" - (cmp:calling-convention-vaslist* calling-conv) - nremaining))))) - (clasp-cleavir::out rest rest-var)))) + (let ((rest + (cond ((eq rest-alloc 'ignore) + ;; &rest variable is ignored- allocate nothing + (irc-undef-value-get %t*%)) + ((eq rest-alloc 'dynamic-extent) + ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. + (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) + (irc-intrinsic "cc_gatherDynamicExtentRestArguments" + args nremaining + (irc-bit-cast rrest %t**%)))) + (varest-p + #+(or) + (irc-tag-vaslist args "rest") + ;;#+(or) + (let ((temp-vaslist (alloca-vaslist :label "rest"))) + (irc-intrinsic "cc_gatherVaRestArguments" + args nremaining temp-vaslist))) + (t + ;; general case- heap allocation + (irc-intrinsic "cc_gatherRestArguments" + args nremaining))))) + (clasp-cleavir::out rest rest-var))) -;;; Keyword processing is the most complicated part, unsurprisingly. #| +Keyword processing is the most complicated part, unsurprisingly. +We process the arguments from back to front, e.g. in :a 7 :a 8 we'd set A +to 8 first, and then to 7 later, since the semantics demand that A +eventually end up as 7. Here is pseudo-C for the parser for (&key a). [foo] indicates an inserted constant. Having to write with phi nodes unfortunately makes things rather more confusing. if ((remaining_nargs % 2) == 1) - cc_oddKeywordException([*current-function-description*]); + cc_oddKeywordException([*fname*]); tstar bad_keyword = undef; bool seen_bad_keyword = false; -t_star a_temp = undef, a_p_temp = [nil], allow_other_keys_temp = [nil], allow_other_keys_p_temp = [nil]; +tstar allow_other_keys = [nil], allow_other_keys_p = [nil]; for (; remaining_nargs != 0; remaining_nargs -= 2) { - tstar key = va_arg(vaslist), value = va_arg(vaslist); + tstar key = remaining_args[remaining_nargs - 2]; + tstar value = remaining_args[remaining_nargs - 1]; if (key == [:a]) { - if (a_p_temp == [nil]) { - a_p_temp = [t]; a_temp = value; continue; - } else continue; + a_p = [t]; a = value; continue; } + ...ditto for other keys... if (key == [:allow-other-keys]) { - if (allow_other_keys_p_temp == [nil]) { - allow_other_keys_p_temp = [t]; allow_other_keys_temp = value; continue; - } else continue; - } - seen_bad_keyword = true; bad_keyword = key; + allow_other_keys_p = [t]; allow_other_keys = value; continue; + } else { seen_bad_keyword = true; bad_keyword = key; } } if (seen_bad_keyword) - cc_ifBadKeywordArgumentException(allow_other_keys_temp, bad_keyword, [*current-function-description*]); -a_p = a_p_temp; a = a_temp; + cc_ifBadKeywordArgumentException(allow_other_keys, bad_keyword, [*fname*]); |# -(defun compile-one-key-test (keyword key-arg suppliedp-phi cont-block false) +;;; Returns a new block that is jumped to when the keyword does match. +;;; This is used to set up a phi to actually "assign" the value. +(defun compile-one-key-test (keyword key-arg cont-block) (let* ((keystring (string keyword)) ;; NOTE: We might save a bit of time by moving this out of the loop. ;; Or maybe LLVM can handle it. I don't know. (key-const (clasp-cleavir::literal keyword)) (match (irc-basic-block-create (core:fmt nil "matched-{}" keystring))) (mismatch (irc-basic-block-create (core:fmt nil "not-{}" keystring)))) - (let ((test (irc-icmp-eq key-arg key-const))) - (irc-cond-br test match mismatch)) + (irc-cond-br (irc-icmp-eq key-arg key-const) match mismatch) (irc-begin-block match) - (let* ((new (irc-basic-block-create (core:fmt nil "new-{}" keystring))) - (old (irc-basic-block-create (core:fmt nil "old-{}" keystring)))) - (let ((test (irc-icmp-eq suppliedp-phi false))) - (irc-cond-br test new old)) - (irc-begin-block new) (irc-br cont-block) - (irc-begin-block old) (irc-br cont-block) - (irc-begin-block mismatch) - (values new old)))) - -(defun compile-key-arguments (keyargs lambda-list-aokp nremaining calling-conv false true) + (irc-br cont-block) + (irc-begin-block mismatch) + match)) + +(defun compile-key-arguments (keyargs lambda-list-aokp nremaining remaining false true fname) (macrolet ((do-keys ((keyword) &body body) - `(loop for (,keyword) on (cdr keyargs) by #'cddddr - do (progn ,@body)))) + `(do* ((cur-key (cdr keyargs) (cddddr cur-key)) + (,keyword (car cur-key) (car cur-key))) + ((endp cur-key)) + ,@body))) (let ((aok-parameter-p nil) allow-other-keys (nkeys (car keyargs)) @@ -210,15 +265,12 @@ a_p = a_p_temp; a = a_temp; (irc-cond-br evenp kw-loop odd-kw) ;; There have been an odd number of arguments, so signal an error. (irc-begin-block odd-kw) - (unless (calling-convention-closure calling-conv) - (error "The calling-conv ~s does not have a closure" calling-conv)) - (irc-intrinsic "cc_oddKeywordException" - (calling-convention-closure calling-conv)) + (irc-intrinsic "cc_oddKeywordException" fname) (irc-unreachable)) ;; Loop starts; welcome hell (irc-begin-block kw-loop) (let ((top-param-phis nil) (top-suppliedp-phis nil) - (new-blocks nil) (old-blocks nil) + (new-blocks nil) (nargs-remaining (irc-phi %size_t% 2 "nargs-remaining")) (sbkw (irc-phi %i1% 2 "seen-bad-keyword")) (bad-keyword (irc-phi %t*% 2 "bad-keyword"))) @@ -244,14 +296,18 @@ a_p = a_p_temp; a = a_temp; (irc-cond-br zerop after matching)) (irc-begin-block matching) ;; Start matching keywords - (let ((key-arg (calling-convention-vaslist.va-arg calling-conv)) - (value-arg (calling-convention-vaslist.va-arg calling-conv))) - (loop for (key) on (cdr keyargs) by #'cddddr - for suppliedp-phi in top-suppliedp-phis - do (multiple-value-bind (new-block old-block) - (compile-one-key-test key key-arg suppliedp-phi kw-loop-continue false) - (push new-block new-blocks) (push old-block old-blocks))) - (setf new-blocks (nreverse new-blocks) old-blocks (nreverse old-blocks)) + ;; We process right to left. This means that we process the leftmost + ;; instance of any keyword last, to match the language semantics. + (let* (;; FIXME: These subs can be nuw + (key-idx (irc-sub nargs-remaining (irc-size_t 2) "key-idx")) + (key-addr (irc-typed-gep %t**% remaining (list key-idx) "key*")) + (key-arg (irc-typed-load %t*% key-addr)) + (value-idx (irc-sub nargs-remaining (irc-size_t 1) "val-idx")) + (val-addr (irc-typed-gep %t**% remaining (list value-idx) "value*")) + (value-arg (irc-typed-load %t*% val-addr))) + (do-keys (key) + (push (compile-one-key-test key key-arg kw-loop-continue) new-blocks)) + (setf new-blocks (nreverse new-blocks)) ;; match failure - as usual, works through phi (irc-branch-to-and-begin-block unknown-kw) (irc-br kw-loop-continue) @@ -269,10 +325,7 @@ a_p = a_p_temp; a = a_temp; ;; If we're coming from a match block, don't change anything. (dolist (new-block new-blocks) (irc-phi-add-incoming bot-sbkw sbkw new-block) - (irc-phi-add-incoming bot-bad-keyword bad-keyword new-block)) - (dolist (old-block old-blocks) - (irc-phi-add-incoming bot-sbkw sbkw old-block) - (irc-phi-add-incoming bot-bad-keyword bad-keyword old-block))) + (irc-phi-add-incoming bot-bad-keyword bad-keyword new-block))) ;; OK now the actual keyword values. (do* ((var-new-blocks new-blocks (cdr var-new-blocks)) (var-new-block (car var-new-blocks) (car var-new-blocks)) @@ -297,11 +350,7 @@ a_p = a_p_temp; a = a_temp; (irc-phi-add-incoming suppliedp-phi true new-block)) (t (irc-phi-add-incoming var-phi top-param-phi new-block) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block)))) - ;; All old-blocks stick with what they have. - (dolist (old-block old-blocks) - (irc-phi-add-incoming var-phi top-param-phi old-block) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi old-block)))))) + (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block)))))))) (let ((dec (irc-sub nargs-remaining (irc-size_t 2)))) (irc-phi-add-incoming nargs-remaining dec kw-loop-continue)) (irc-br kw-loop) @@ -316,16 +365,21 @@ a_p = a_p_temp; a = a_temp; (irc-intrinsic "cc_ifBadKeywordArgumentException" ;; aok was initialized to NIL, regardless of the suppliedp, so this is ok. - allow-other-keys bad-keyword (calling-convention-closure calling-conv)) + allow-other-keys bad-keyword fname) (irc-br kw-assigns) (irc-begin-block kw-assigns))) - (loop for top-param-phi in top-param-phis - for top-suppliedp-phi in top-suppliedp-phis - for (key _ var suppliedp) on (cdr keyargs) by #'cddddr - when (or (not (eq key :allow-other-keys)) - lambda-list-aokp aok-parameter-p) - do (clasp-cleavir::out top-param-phi var) - (clasp-cleavir::out top-suppliedp-phi suppliedp)))))) + (do* ((top-param-phis top-param-phis (cdr top-param-phis)) + (top-param-phi (car top-param-phis) (car top-param-phis)) + (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) + (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis)) + (cur-key (cdr keyargs) (cddddr cur-key)) + (key (car cur-key) (car cur-key)) + (var (caddr cur-key) (caddr cur-key)) + (suppliedp (cadddr cur-key) (cadddr cur-key))) + ((endp cur-key)) + (when (or (not (eq key :allow-other-keys)) lambda-list-aokp aok-parameter-p) + (clasp-cleavir::out top-param-phi var) + (clasp-cleavir::out top-suppliedp-phi suppliedp))))))) (defun compile-general-lambda-list-code (reqargs optargs @@ -334,10 +388,11 @@ a_p = a_p_temp; a = a_temp; key-flag keyargs allow-other-keys - calling-conv - &key (safep t)) + xepargs + &key (safep t) + fname rest-alloc) (cmp-log "Entered compile-general-lambda-list-code%N") - (let* ((nargs (calling-convention-nargs calling-conv)) + (let* ((nargs (xep-nargs xepargs)) (nreq (car reqargs)) (nopt (car optargs)) (nfixed (+ nreq nopt)) @@ -347,162 +402,42 @@ a_p = a_p_temp; a = a_temp; (irc-size_t nfixed))) (wrong-nargs-block (when safep - (compile-wrong-number-arguments-block - (calling-convention-closure calling-conv) - nargs creq cmax))) + (compile-wrong-number-arguments-block fname nargs creq cmax))) ;; NOTE: Sometimes we don't actually need these. ;; We could save miniscule time by not generating. (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) (unless (zerop nreq) (when safep (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) - (compile-required-arguments reqargs calling-conv)) + (compile-required-arguments xepargs reqargs)) (unless (zerop nopt) - (compile-optional-arguments optargs nreq calling-conv iNIL iT)) + (compile-optional-arguments xepargs optargs nreq iNIL iT)) (if (or rest-var key-flag) ;; We have &key and/or &rest, so parse with that expectation. ;; Specifically, we have to get a variable for how many arguments are left after &optional. - (let ((nremaining - (if (zerop nopt) - ;; With no optional arguments it's trivial. - (irc-sub nargs creq "nremaining") - ;; Otherwise we need nargs - nfixed, clamped to min 0. - ;; (Since nfixed > nargs is possible.) - ;; We used to have compile-optional-arguments return - ;; the number of remaining arguments, but that's a bit - ;; of pointless code for the rare case that we have - ;; both &optional and &rest/&key. - (irc-intrinsic "llvm.usub.sat.i64" nargs - (irc-size_t nfixed))))) + (let* ((nremaining + (if (zerop nopt) + ;; With no optional arguments it's trivial. + (irc-sub nargs creq "nremaining") + ;; Otherwise we need nargs - nfixed, clamped to min 0. + ;; (Since nfixed > nargs is possible.) + ;; We used to have compile-optional-arguments return + ;; the number of remaining arguments, but that's a bit + ;; of pointless code for the rare case that we have + ;; both &optional and &rest/&key. + (irc-intrinsic "llvm.usub.sat.i64" nargs + (irc-size_t nfixed)))) + (remaining (remaining-args xepargs nfixed))) ;; Note that we don't need to check for too many arguments here. (when rest-var - (compile-rest-argument rest-var varest-p nremaining calling-conv)) + (compile-rest-argument rest-var varest-p rest-alloc remaining nremaining)) (when key-flag (compile-key-arguments keyargs (or allow-other-keys (not safep)) - nremaining calling-conv iNIL iT))) + nremaining remaining iNIL iT fname))) (when safep (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))) - - - -(defun compile-only-req-and-opt-arguments (arity cleavir-lambda-list-analysis calling-conv &key (safep t)) - (multiple-value-bind (reqargs optargs) - (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) - (let* ((register-args (calling-convention-register-args calling-conv)) - (nargs (calling-convention-nargs calling-conv)) - (nreq (car (cleavir-lambda-list-analysis-required cleavir-lambda-list-analysis))) - (creq (irc-size_t nreq)) - (nopt (car (cleavir-lambda-list-analysis-optional cleavir-lambda-list-analysis))) - (cmax (irc-size_t (+ nreq nopt))) - (error-block - ;; see kludge above - (when safep - (compile-wrong-number-arguments-block - (calling-convention-closure calling-conv) - nargs creq cmax)))) - ;; fixme: it would probably be nicer to generate one switch such that not-enough-arguments - ;; goes to an error block and too-many goes to another. then we'll only have one test on - ;; the argument count. llvm might reduce it to that anyway, though. - (flet ((ensure-register (registers undef &optional name) - (declare (ignore name)) - (let ((register (car registers))) - (if register - register - undef)))) - (unless (cmp:generate-function-for-arity-p arity cleavir-lambda-list-analysis) - (let ((error-block (compile-wrong-number-arguments-block (calling-convention-closure calling-conv) - (jit-constant-i64 (length register-args)) - (jit-constant-i64 nreq) - (jit-constant-i64 (+ nreq nopt))))) - (irc-br error-block) - (return-from compile-only-req-and-opt-arguments nil))) - ;; required arguments - (when (> nreq 0) - (when safep - (compile-error-if-not-enough-arguments error-block creq nargs)) - (dolist (req (cdr reqargs)) - ;; we pop the register-args so that the optionals below won't use em. - (clasp-cleavir::out (pop register-args) req))) - ;; optional arguments. code is mostly the same as compile-optional-arguments (fixme). - (if (> nopt 0) - (let* ((npreds (1+ nopt)) - (undef (irc-undef-value-get %t*%)) - (true (clasp-cleavir::%t)) - (false (clasp-cleavir::%nil)) - (default (irc-basic-block-create "enough-for-optional")) - (assn (irc-basic-block-create "optional-assignments")) - (after (irc-basic-block-create "argument-parsing-done")) - (sw (irc-switch nargs default nopt)) - (var-phis nil) (suppliedp-phis nil)) - (irc-begin-block assn) - (dotimes (i nopt) - (push (irc-phi %t*% npreds) var-phis) - (push (irc-phi %t*% npreds) suppliedp-phis)) - (loop for (var suppliedp) on (cdr optargs) by #'cdddr - for var-phi in var-phis - for suppliedp-phi in suppliedp-phis - do (clasp-cleavir::out suppliedp-phi suppliedp) - (clasp-cleavir::out var-phi var)) - (irc-br after) - ;; each case - (dotimes (i nopt) - (let* ((opti (+ i nreq)) - (blck (irc-basic-block-create (core:fmt nil "supplied-{}-arguments" opti)))) - (llvm-sys:add-case sw (irc-size_t opti) blck) - (do ((var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (registers register-args (cdr registers)) - (optj nreq (1+ optj))) - ((endp var-phis)) - (cond ((< optj opti) ; enough arguments - (irc-phi-add-incoming (car suppliedp-phis) true blck) - (irc-phi-add-incoming (car var-phis) (ensure-register registers undef :nopt) blck)) - (t ; nope - (irc-phi-add-incoming (car suppliedp-phis) false blck) - (irc-phi-add-incoming (car var-phis) undef blck)))) - (irc-begin-block blck) (irc-br assn))) - ;; default - ;; just use a register for each argument - ;; we have to use another block because compile-error-etc does an invoke - ;; and generates more blocks. - (let ((default-cont (irc-basic-block-create "enough-for-optional-continued"))) - (do ((var-phis var-phis (cdr var-phis)) - (suppliedp-phis suppliedp-phis (cdr suppliedp-phis)) - (registers register-args (cdr registers))) - ((endp var-phis)) - (irc-phi-add-incoming (car suppliedp-phis) true default-cont) - (irc-phi-add-incoming (car var-phis) (ensure-register registers undef :var-phis) default-cont)) - (irc-begin-block default) - ;; test for too many arguments - (when safep - (compile-error-if-too-many-arguments error-block cmax nargs)) - (irc-branch-to-and-begin-block default-cont) - (irc-br assn) - ;; and, done. - (irc-begin-block after))) - ;; no optional arguments, so not much to do - (when safep - (compile-error-if-too-many-arguments error-block cmax nargs))))))) - -(defun req-opt-only-p (cleavir-lambda-list) - (let ((nreq 0) (nopt 0) (req-opt-only t) - (state nil)) - (dolist (item cleavir-lambda-list) - (cond ((eq item '&optional) - (if (eq state '&optional) - (progn (setf req-opt-only nil) ; dupe &optional; just mark as general - (return)) - (setf state '&optional))) - ((member item lambda-list-keywords) - (setf req-opt-only nil) - (return)) - (t (if (eq state '&optional) - (incf nopt) - (incf nreq))))) - (values req-opt-only nreq nopt))) - (defun lambda-list-arguments (lambda-list) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys auxargs varest-p) (core:process-lambda-list lambda-list 'function) @@ -581,7 +516,6 @@ a_p = a_p_temp; a = a_temp; (arguments (lambda-list-arguments cleavir-lambda-list))) (make-cleavir-lambda-list-analysis :cleavir-lambda-list (ensure-cleavir-lambda-list lambda-list) ; Is this correct? - :req-opt-only-p (req-opt-only-p (ensure-cleavir-lambda-list lambda-list)) :lambda-list-arguments arguments :required (cons required-count (nreverse required)) :optional (cons optional-count (nreverse optional)) @@ -592,66 +526,17 @@ a_p = a_p_temp; a = a_temp; :aux-p nil ; aux-p; unused here :va-rest-p (if (eq rest-type 'core:&va-rest) t nil))))) - - -(defun may-use-only-registers (cleavir-lambda-list-analysis) - (multiple-value-bind (req-opt-only nreq nopt) - (req-opt-only-p (cleavir-lambda-list-analysis-cleavir-lambda-list cleavir-lambda-list-analysis)) - (and req-opt-only - (and (<= +entry-point-arity-begin+ (+ nreq nopt)) - (< (+ nreq nopt) +entry-point-arity-end+))))) - ;;; Main entry point. Called for effect. -(defun compile-lambda-list-code (cleavir-lambda-list-analysis calling-conv arity - &key (safep t)) +(defun compile-lambda-list-code (cleavir-lambda-list-analysis xepargs + &key (safep t) rest-alloc + (fname (clasp-cleavir::%nil))) "Return T if arguments were processed and NIL if they were not" (cmp-log "about to compile-lambda-list-code cleavir-lambda-list-analysis: {}%N" cleavir-lambda-list-analysis) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) (declare (ignore unused-auxs)) - (cmp-log " reqargs -> {}%N" reqargs) - (cmp-log " optargs -> {}%N" optargs) - (cmp-log " keyargs -> {}%N" keyargs) - (cond - ((eq arity :general-entry) - (compile-general-lambda-list-code reqargs - optargs - rest-var - varest-p - key-flag - keyargs - allow-other-keys - calling-conv - :safep safep) - t ;; always successful for general lambda-list processing - ) - ((and (fixnump arity) - (may-use-only-registers cleavir-lambda-list-analysis)) - (compile-only-req-and-opt-arguments arity cleavir-lambda-list-analysis - calling-conv - :safep safep)) - (t (let* ((register-args (calling-convention-register-args calling-conv)) - (nargs (length register-args)) - (arg-buffer (if (= nargs 0) - nil - (alloca-arguments nargs "ll-args"))) - (vaslist* (alloca-vaslist)) - (idx 0)) - (dolist (arg register-args) - (let ((arg-gep (irc-typed-gep (llvm-sys:array-type-get %t*% nargs) arg-buffer (list 0 idx)))) - (incf idx) - (irc-store arg arg-gep))) - (if (= nargs 0) - (vaslist-start vaslist* (jit-constant-i64 nargs)) - (vaslist-start vaslist* (jit-constant-i64 nargs) - (irc-bit-cast arg-buffer %i8**%))) - (setf (calling-convention-vaslist* calling-conv) vaslist*) - (compile-general-lambda-list-code reqargs - optargs - rest-var - varest-p - key-flag - keyargs - allow-other-keys - calling-conv - :safep safep)))))) + (compile-general-lambda-list-code reqargs optargs rest-var varest-p + key-flag keyargs allow-other-keys + xepargs + :safep safep :rest-alloc rest-alloc + :fname fname))) diff --git a/src/lisp/kernel/cleavir/clasp-cleavir.asd b/src/lisp/kernel/cleavir/clasp-cleavir.asd index 3904c8359d..d575e8d254 100644 --- a/src/lisp/kernel/cleavir/clasp-cleavir.asd +++ b/src/lisp/kernel/cleavir/clasp-cleavir.asd @@ -28,6 +28,7 @@ (:file "ir") (:file "jit") (:file "translation-environment") + (:file "arguments") (:file "bir") (:file "bmir") (:file "blir") diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 22aec5d95c..93b9a64c7c 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1787,26 +1787,33 @@ (t (loop for i from 0 below (length rtype) collect (cmp:irc-extract-value llvm-value (list i)))))) -(defun layout-xep-function* (xep-group arity the-function ir calling-convention abi) +(defun layout-xep-function* (xep-group arity the-function ir abi) (declare (ignore abi)) (cmp:with-irbuilder (cmp:*irbuilder-function-alloca*) ;; Parse lambda list. (cmp:with-landing-pad nil - (cmp:compile-lambda-list-code - (cmp:xep-group-cleavir-lambda-list-analysis xep-group) - calling-convention arity) - ;; Import cells. - (let* ((closure-vec (first (llvm-sys:get-argument-list the-function))) - (llvm-function-info (find-llvm-function-info ir)) - (environment-values - (loop for import in (environment llvm-function-info) - for i from 0 - for offset = (cmp:%closure%.offset-of[n]/t* i) - when import ; skip unused fixed closure entries - collect (cmp:irc-t*-load-atomic - (cmp::gen-memref-address closure-vec offset))))) - ;; Tail call the real function. - (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info))) + (let* ((args (llvm-sys:get-argument-list the-function)) + (closure-vec (first args)) + (analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group))) + (cmp:compile-lambda-list-code + analysis + (if (eq arity :general-entry) + (make-instance 'cmp::general-xep-arguments + :array (third args) :nargs (second args)) + (make-instance 'cmp::fixed-xep-arguments + :arguments (rest args))) + :fname closure-vec :rest-alloc (compute-rest-alloc analysis)) + ;; Import cells. + (let* ((llvm-function-info (find-llvm-function-info ir)) + (environment-values + (loop for import in (environment llvm-function-info) + for i from 0 + for offset = (cmp:%closure%.offset-of[n]/t* i) + when import ; skip unused fixed closure entries + collect (cmp:irc-t*-load-atomic + (cmp::gen-memref-address closure-vec offset)))) + ;; Tail call the real function. + (function-type (llvm-sys:get-function-type (main-function llvm-function-info))) (arguments (mapcar (lambda (arg) (translate-cast (in arg) @@ -1957,19 +1964,11 @@ 999903)) (if sys:*drag-native-calls* (cmp::irc-intrinsic "drag_native_calls")) - (let* ((cleavir-lambda-list-analysis - (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) - (rest-alloc - (compute-rest-alloc cleavir-lambda-list-analysis)) - (calling-convention - (cmp:initialize-calling-convention - xep-arity-function arity - :rest-alloc rest-alloc))) - (when (policy:policy-value (bir:policy function) - 'save-register-args) - (save-registers xep-arity-function arity - (cmp:alloca-register-save-area arity))) - (layout-xep-function* xep-group arity xep-arity-function function calling-convention abi)))))))))) + (when (policy:policy-value (bir:policy function) + 'save-register-args) + (save-registers xep-arity-function arity + (cmp:alloca-register-save-area arity))) + (layout-xep-function* xep-group arity xep-arity-function function abi))))))))) ;;; Generate code to dump arguments ("registers") to a "register save area" in ;;; memory, where they can be read by the debugger even in the face of diff --git a/src/lisp/kernel/cmp/cmpexports.lisp b/src/lisp/kernel/cmp/cmpexports.lisp index d6d2b533fc..4e727f14a6 100644 --- a/src/lisp/kernel/cmp/cmpexports.lisp +++ b/src/lisp/kernel/cmp/cmpexports.lisp @@ -126,11 +126,6 @@ irc-apply function-type-create-on-the-fly evaluate-foreign-arguments - calling-convention-closure - calling-convention-vaslist* - calling-convention-vaslist.va-arg - calling-convention-nargs - calling-convention-register-args cmp-log cmp-log-dump-module cmp-log-dump-function @@ -146,7 +141,6 @@ compile-error-if-not-enough-arguments compile-lambda-function compile-lambda-list-code - make-calling-convention compiler-error compiler-warn compiler-style-warn @@ -308,7 +302,6 @@ jit-constant-unique-string-ptr module-make-global-string make-boot-function-global-variable - initialize-calling-convention ensure-cleavir-lambda-list ensure-cleavir-lambda-list-analysis process-cleavir-lambda-list-analysis diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index fdcf0c3f69..a945edfa4d 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -615,52 +615,6 @@ Boehm and MPS use a single pointer" (irc-store shifted-nargs-next shifted-nargs*) val)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Provide the arguments passed to the function in a convenient manner. -;; Either the register arguments are available in register-args -;; or the vaslist is used to access the arguments -;; one after the other with calling-convention.va-arg -(defstruct (calling-convention (:type vector) :named) - closure - nargs - register-args ; The arguments that were passed in registers - vaslist* ; The address of the vaslist, or NIL - rest-alloc ; whether we can dx or ignore a &rest argument - ) - -;; Parse the function arguments into a calling-convention - -(defun initialize-calling-convention (llvm-function arity &key rest-alloc) - (let* ((arguments (llvm-sys:get-argument-list llvm-function)) - (closure (first arguments))) - (unless closure - (error "initialize-calling-convention for arguments ~a - the closure is NIL" arguments)) - (cond - ((eq arity :general-entry) - (let* ((nargs (second arguments)) - (args (third arguments)) - (vaslist* (alloca-vaslist))) - (vaslist-start vaslist* nargs args) - (make-calling-convention :closure closure - :nargs nargs - :vaslist* vaslist* - :rest-alloc rest-alloc))) - (t - (let ((nargs (length (cdr arguments))) - (register-args (cdr arguments))) - (make-calling-convention :closure closure - :nargs (jit-constant-i64 nargs) - :register-args register-args - :rest-alloc rest-alloc)))))) - -;;; -;;; Read the next argument from the vaslist -(defun calling-convention-vaslist.va-arg (cc) - (let* ((vaslist (calling-convention-vaslist* cc))) - (gen-vaslist-pop vaslist))) - (defun fn-prototype (arity) (cond ((eq arity :general-entry) diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cmp/cmpir.lisp index 5d0819d0d4..aa9f3a7666 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cmp/cmpir.lisp @@ -83,7 +83,6 @@ That layout looks like: * Return true if bindings will be defined and false if not. " cleavir-lambda-list - req-opt-only-p (lambda-list-arguments nil) (required (list 0)) ; default zero required (optional (list 0)) ; default zero optional @@ -136,12 +135,12 @@ Maybe in the future we will want to actually put a test here." If nil then insert a general_entry_point_redirect_x function which just calls the general entry point. This is useful for entry points that just signal an argcount mismatch error - we can just use existing entry point functions that defer to the general rather than generating more code." (if (eq arity :general-entry) t - (if (cleavir-lambda-list-analysis-req-opt-only-p cll-analysis) - (let* ((nreq (car (cleavir-lambda-list-analysis-required cll-analysis))) - (nopt (car (cleavir-lambda-list-analysis-optional cll-analysis)))) - (not (or (< arity nreq) - (< (+ nreq nopt) arity)))) - nil))) + (let* ((nreq (car (cleavir-lambda-list-analysis-required cll-analysis))) + (nopt (car (cleavir-lambda-list-analysis-optional cll-analysis)))) + (and (not (or (< arity nreq) + (< (+ nreq nopt) arity))) + (null (cleavir-lambda-list-analysis-rest cll-analysis)) + (not (cleavir-lambda-list-analysis-key-flag cll-analysis)))))) (defstruct (xep-group (:type vector) :named) "xep-group describes a group of xep functions. @@ -255,6 +254,9 @@ local-function - the lcl function that all of the xep functions call." (let ((fixed-indices (irc-fix-gep-indices indices))) (llvm-sys:create-in-bounds-gep *irbuilder* type ptr fixed-indices name ))) +(defun irc-const-gep1-64 (type ptr index &optional (label "gep")) + (ensure-opaque-or-pointee-type-matches ptr type) + (llvm-sys:create-const-gep1-64 *irbuilder* type ptr index label)) (defun irc-const-gep2-64 (type ptr idx0 idx1 label) (ensure-opaque-or-pointee-type-matches ptr type) (llvm-sys:create-const-gep2-64 *irbuilder* type ptr idx0 idx1 label)) diff --git a/src/lisp/kernel/cmp/primitives.lisp b/src/lisp/kernel/cmp/primitives.lisp index d0dda96416..c0c1a205c4 100644 --- a/src/lisp/kernel/cmp/primitives.lisp +++ b/src/lisp/kernel/cmp/primitives.lisp @@ -116,9 +116,9 @@ (primitive "cc_list" :t* (list :size_t) :varargs t) (primitive "cc_mvcGatherRest" :t* (list :size_t :t* :size_t)) (primitive "cc_mvcGatherRest2" :t* (list :t** :size_t)) - (primitive "cc_gatherRestArguments" :t* (list :vaslist* :size_t)) - (primitive "cc_gatherDynamicExtentRestArguments" :t* (list :vaslist* :size_t :t**)) - (primitive "cc_gatherVaRestArguments" :t* (list :vaslist* :size_t :vaslist*)) + (primitive "cc_gatherRestArguments" :t* (list :t** :size_t)) + (primitive "cc_gatherDynamicExtentRestArguments" :t* (list :t** :size_t :t*)) + (primitive "cc_gatherVaRestArguments" :t* (list :t** :size_t :vaslist*)) (primitive-unwinds "cc_ifBadKeywordArgumentException" :void (list :t* :t* :t*)) (primitive-unwinds "cc_error_bugged_come_from" :void (list :size_t) :does-not-return t) diff --git a/src/lisp/kernel/cmp/workbench.lisp b/src/lisp/kernel/cmp/workbench.lisp index 5b0405601b..b35840b1d7 100644 --- a/src/lisp/kernel/cmp/workbench.lisp +++ b/src/lisp/kernel/cmp/workbench.lisp @@ -1,8 +1,7 @@ (progn (setf cmp::*debug-compiler* t) (setf cmp::*use-human-readable-bitcode* t) - (trace COMPILER:SETUP-CALLING-CONVENTION - COMPILER::IRC-local-FUNCTION-CREATE + (trace COMPILER::IRC-local-FUNCTION-CREATE cmp::irc-xep-functions-create COMPILER::CODEGEN-FILL-FUNCTION-FRAME COMPILER::CODEGEN-FUNCTION COMPILER::COMPILE-TO-MODULE COMPILER::CODEGEN-CLOSURE COMPILER:COMPILE-LAMBDA-FUNCTION COMPILER::GENERATE-LLVM-FUNCTION-FROM-CODE @@ -53,14 +52,12 @@ cmp::make-xep-arity cmp::irc-calculate-real-args cmp::irc-calculate-call-info - cmp::initialize-calling-convention cmp::compile-wrong-number-arguments-block cmp::compile-error-if-too-many-arguments cmp::compile-error-if-not-enough-arguments cmp::irc-icmp-ugt cmp::bclasp-llvm-function-info-xep-function cmp::maybe-spill-to-register-save-area - cmp::make-calling-convention cmp::layout-xep-function cmp::layout-xep-function* cmp::irc-create-call-wft @@ -72,8 +69,6 @@ cmp::lambda-list-arguments cmp::jit-add-module-return-function cmp::c++-field-ptr - cmp::calling-convention-vaslist.va-arg - cmp::calling-convention-vaslist* cmp::irc-typed-load cmp::irc-add cmp::irc-sub diff --git a/src/llvmo/intrinsics.cc b/src/llvmo/intrinsics.cc index c6c787f5ee..c7868d0d99 100644 --- a/src/llvmo/intrinsics.cc +++ b/src/llvmo/intrinsics.cc @@ -85,10 +85,10 @@ ALWAYS_INLINE core::T_O* cc_ensure_valid_object(core::T_O* tagged_object) { NO_UNWIND_END(); } -ALWAYS_INLINE core::T_O* cc_gatherVaRestArguments(Vaslist* vaslist, std::size_t nargs, Vaslist untagged_vargs_rest[2]) { +ALWAYS_INLINE core::T_O* cc_gatherVaRestArguments(core::T_O** args, std::size_t nargs, Vaslist untagged_vargs_rest[2]) { NO_UNWIND_BEGIN(); - new (&untagged_vargs_rest[0]) Vaslist(nargs, vaslist->args()); - new (&untagged_vargs_rest[1]) Vaslist(nargs, vaslist->args()); + new (&untagged_vargs_rest[0]) Vaslist(nargs, args); + new (&untagged_vargs_rest[1]) Vaslist(nargs, args); T_O* result = untagged_vargs_rest->asTaggedPtr(); #ifdef DEBUG_VASLIST if (_sym_STARdebugVaslistSTAR && _sym_STARdebugVaslistSTAR->symbolValue().notnilp()) { diff --git a/src/llvmo/link_intrinsics.cc b/src/llvmo/link_intrinsics.cc index 78d8c9680e..dee02e3e82 100644 --- a/src/llvmo/link_intrinsics.cc +++ b/src/llvmo/link_intrinsics.cc @@ -610,11 +610,11 @@ T_O* cc_list(size_t nargs, ...) { /* Conses up a &rest argument from the passed valist. * Used in cmp/arguments.lisp for the general case of functions with a &rest in their lambda list. */ -__attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(Vaslist* vaslist, std::size_t nargs) { +__attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(core::T_O** args, std::size_t nargs) { NO_UNWIND_BEGIN(); ql::list result; for (int i = 0; i < nargs; ++i) { - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[i]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[i]); result << gc::smart_ptr((gc::Tagged)tagged_obj); } MAYBE_VERIFY_ALIGNMENT(&*(result.result())); @@ -624,18 +624,18 @@ __attribute__((visibility("default"))) core::T_O* cc_gatherRestArguments(Vaslist /* Like cc_gatherRestArguments, but uses a vector of conses provided by the caller- * intended to be stack space, for &rest parameters declared dynamic-extent. */ -__attribute__((visibility("default"))) core::T_O* cc_gatherDynamicExtentRestArguments(Vaslist* vaslist, std::size_t nargs, +__attribute__((visibility("default"))) core::T_O* cc_gatherDynamicExtentRestArguments(core::T_O** args, std::size_t nargs, core::Cons_O* cur) { NO_UNWIND_BEGIN(); core::List_sp result = Cons_sp((gctools::Tagged)gctools::tag_cons((core::Cons_O*)cur)); if (nargs) { for (int i = 0; i < nargs - 1; ++i) { - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[i]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[i]); Cons_O* next = cur + 1; new (cur) Cons_O(T_sp((gctools::Tagged)tagged_obj), T_sp((gctools::Tagged)gctools::tag_cons((core::Cons_O*)next))); cur = next; } - core::T_O* tagged_obj = ENSURE_VALID_OBJECT((*vaslist)[nargs - 1]); + core::T_O* tagged_obj = ENSURE_VALID_OBJECT(args[nargs - 1]); new (cur) Cons_O(T_sp((gctools::Tagged)tagged_obj), nil()); return result.raw_(); } diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index 2edb3a78a3..daa4fccc33 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -2817,11 +2817,11 @@ CL_EXTERN_DEFMETHOD(IRBuilderBase_O, // CL_EXTERN_DEFMETHOD(IRBuilder_O, &IRBuilder_O::ExternalType::CreateConstGEP2_32); CL_LISPIFY_NAME(CreateConstGEP1-64); CL_EXTERN_DEFMETHOD(IRBuilderBase_O, - (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Value*, uint64_t, const llvm::Twine&)) & + (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Type*, llvm::Value*, uint64_t, const llvm::Twine&)) & IRBuilderBase_O::ExternalType::CreateConstGEP1_64); CL_LISPIFY_NAME(CreateConstInBoundsGEP1-64); CL_EXTERN_DEFMETHOD(IRBuilderBase_O, - (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Value*, uint64_t, const llvm::Twine&)) & + (llvm::Value * (IRBuilderBase_O::ExternalType::*)(llvm::Type*, llvm::Value*, uint64_t, const llvm::Twine&)) & IRBuilderBase_O::ExternalType::CreateConstInBoundsGEP1_64); // CL_LISPIFY_NAME(CreateConstGEP2-64); // CL_EXTERN_DEFMETHOD(IRBuilderBase_O, &IRBuilderBase_O::ExternalType::CreateConstGEP2_64); From d30902fea4643727b5e27fca313447d7dcf35abd Mon Sep 17 00:00:00 2001 From: Bike Date: Thu, 2 May 2024 14:36:55 -0400 Subject: [PATCH 14/37] have argument parser return arguments instead of side effecting should make it easier to use for local calls. bonus: no weird dependence on *datum-values* in xep layouter. --- src/lisp/kernel/cleavir/arguments.lisp | 151 +++++++++++-------------- src/lisp/kernel/cleavir/translate.lisp | 85 +++++++------- 2 files changed, 112 insertions(+), 124 deletions(-) diff --git a/src/lisp/kernel/cleavir/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp index e7f6e7373d..2b9ddd8944 100644 --- a/src/lisp/kernel/cleavir/arguments.lisp +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -71,12 +71,12 @@ (irc-cond-br cmp error-block cont-block) (irc-begin-block cont-block))) -;; Generate code to bind the required arguments. +;; Generate code to bind the required arguments. Return the LLVM values. (defun compile-required-arguments (xepargs reqargs) ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. (loop for i from 0 - for req in (cdr reqargs) - do (clasp-cleavir::out (nth-arg xepargs i) req))) + for req in (rest reqargs) ; maybe use for naming? + collect (nth-arg xepargs i))) (defgeneric compile-optional-arguments (xepargs optargs nreq false true)) (defmethod compile-optional-arguments ((xepargs general-xep-arguments) @@ -108,17 +108,9 @@ switch (nargs) { (irc-begin-block assn) (let ((npreds (1+ nopt)) (var-phis nil) (suppliedp-phis nil)) - ;; We have to do this in two loops to ensure the PHIs come before any code - ;; generated by OUT. (dotimes (i nopt) (push (irc-phi %t*% npreds) suppliedp-phis) (push (irc-phi %t*% npreds) var-phis)) - ;; OK _now_ OUT. - (loop for (var suppliedp) on opts by #'cdddr - for var-phi in var-phis - for suppliedp-phi in suppliedp-phis - do (clasp-cleavir::out suppliedp-phi suppliedp) - (clasp-cleavir::out var-phi var)) (irc-br final) ;; Generate a block for each case. (do ((i nreq (1+ i))) @@ -143,7 +135,11 @@ switch (nargs) { do (irc-phi-add-incoming var-phi (nth-arg xepargs i) enough)) (irc-br assn) ;; ready to generate more code - (irc-begin-block final)))) + (irc-begin-block final) + (loop for (var suppliedp) on opts by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis + collect var-phi collect suppliedp-phi)))) (defmethod compile-optional-arguments ((xepargs fixed-xep-arguments) optargs nreq false true) @@ -153,37 +149,31 @@ switch (nargs) { with undef = (irc-undef-value-get %t*%) for (var suppliedp) on (rest optargs) by #'cdddr for arg = (pop args) - do (multiple-value-bind (val sp) - (if (null arg) ; out of arguments - (values undef false) - (values arg true)) - (clasp-cleavir::out sp suppliedp) - (clasp-cleavir::out val var)))) + for val = (if (null arg) undef arg) + for sp = (if (null arg) false true) + collect val collect sp)) (defun compile-rest-argument (rest-var varest-p rest-alloc args nremaining) + (declare (ignore rest-var)) ; old, maybe use for label name later? (cmp:irc-branch-to-and-begin-block (cmp:irc-basic-block-create "process-rest-argument")) - (let ((rest - (cond ((eq rest-alloc 'ignore) - ;; &rest variable is ignored- allocate nothing - (irc-undef-value-get %t*%)) - ((eq rest-alloc 'dynamic-extent) - ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. - (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) - (irc-intrinsic "cc_gatherDynamicExtentRestArguments" - args nremaining - (irc-bit-cast rrest %t**%)))) - (varest-p - #+(or) - (irc-tag-vaslist args "rest") - ;;#+(or) - (let ((temp-vaslist (alloca-vaslist :label "rest"))) - (irc-intrinsic "cc_gatherVaRestArguments" - args nremaining temp-vaslist))) - (t - ;; general case- heap allocation - (irc-intrinsic "cc_gatherRestArguments" - args nremaining))))) - (clasp-cleavir::out rest rest-var))) + (list + (cond ((eq rest-alloc 'ignore) + ;; &rest variable is ignored- allocate nothing + (irc-undef-value-get %t*%)) + ((eq rest-alloc 'dynamic-extent) + ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. + (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) + (irc-intrinsic "cc_gatherDynamicExtentRestArguments" + args nremaining + (irc-bit-cast rrest %t**%)))) + (varest-p + (let ((temp-vaslist (alloca-vaslist :label "rest"))) + (irc-intrinsic "cc_gatherVaRestArguments" + args nremaining temp-vaslist))) + (t + ;; general case- heap allocation + (irc-intrinsic "cc_gatherRestArguments" + args nremaining))))) #| Keyword processing is the most complicated part, unsurprisingly. @@ -368,21 +358,16 @@ if (seen_bad_keyword) allow-other-keys bad-keyword fname) (irc-br kw-assigns) (irc-begin-block kw-assigns))) - (do* ((top-param-phis top-param-phis (cdr top-param-phis)) - (top-param-phi (car top-param-phis) (car top-param-phis)) - (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) - (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis)) - (cur-key (cdr keyargs) (cddddr cur-key)) - (key (car cur-key) (car cur-key)) - (var (caddr cur-key) (caddr cur-key)) - (suppliedp (cadddr cur-key) (cadddr cur-key))) - ((endp cur-key)) - (when (or (not (eq key :allow-other-keys)) lambda-list-aokp aok-parameter-p) - (clasp-cleavir::out top-param-phi var) - (clasp-cleavir::out top-suppliedp-phi suppliedp))))))) + (loop for top-param-phi in top-param-phis + for top-suppliedp-phi in top-suppliedp-phis + for (key) on (cdr keyargs) by #'cddddr + when (or (not (eq key :allow-other-keys)) + lambda-list-aokp aok-parameter-p) + collect top-param-phi + and collect top-suppliedp-phi))))) -(defun compile-general-lambda-list-code (reqargs - optargs +(defun compile-general-lambda-list-code (reqargs + optargs rest-var varest-p key-flag @@ -406,37 +391,40 @@ if (seen_bad_keyword) ;; NOTE: Sometimes we don't actually need these. ;; We could save miniscule time by not generating. (iNIL (clasp-cleavir::%nil)) (iT (clasp-cleavir::%t))) - (unless (zerop nreq) - (when safep - (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) - (compile-required-arguments xepargs reqargs)) - (unless (zerop nopt) - (compile-optional-arguments xepargs optargs nreq iNIL iT)) - (if (or rest-var key-flag) - ;; We have &key and/or &rest, so parse with that expectation. - ;; Specifically, we have to get a variable for how many arguments are left after &optional. - (let* ((nremaining - (if (zerop nopt) - ;; With no optional arguments it's trivial. - (irc-sub nargs creq "nremaining") - ;; Otherwise we need nargs - nfixed, clamped to min 0. - ;; (Since nfixed > nargs is possible.) - ;; We used to have compile-optional-arguments return - ;; the number of remaining arguments, but that's a bit - ;; of pointless code for the rare case that we have - ;; both &optional and &rest/&key. - (irc-intrinsic "llvm.usub.sat.i64" nargs - (irc-size_t nfixed)))) - (remaining (remaining-args xepargs nfixed))) - ;; Note that we don't need to check for too many arguments here. + (append + (unless (zerop nreq) + (when safep + (compile-error-if-not-enough-arguments wrong-nargs-block creq nargs)) + (compile-required-arguments xepargs reqargs)) + (unless (zerop nopt) + (compile-optional-arguments xepargs optargs nreq iNIL iT)) + (if (or rest-var key-flag) + ;; We have &key and/or &rest, so parse with that expectation. + ;; Specifically, we have to get a variable for how many arguments are left after &optional. + (let* ((nremaining + (if (zerop nopt) + ;; With no optional arguments it's trivial. + (irc-sub nargs creq "nremaining") + ;; Otherwise we need nargs - nfixed, clamped to min 0. + ;; (Since nfixed > nargs is possible.) + ;; We used to have compile-optional-arguments return + ;; the number of remaining arguments, but that's a bit + ;; of pointless code for the rare case that we have + ;; both &optional and &rest/&key. + (irc-intrinsic "llvm.usub.sat.i64" nargs + (irc-size_t nfixed)))) + (remaining (remaining-args xepargs nfixed))) + ;; Note that we don't need to check for too many arguments here. + (append (when rest-var (compile-rest-argument rest-var varest-p rest-alloc remaining nremaining)) (when key-flag (compile-key-arguments keyargs (or allow-other-keys (not safep)) - nremaining remaining iNIL iT fname))) + nremaining remaining iNIL iT fname)))) (when safep (cmp-log "Last if-too-many-arguments {} {}" cmax nargs) - (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs))))) + (compile-error-if-too-many-arguments wrong-nargs-block cmax nargs) + nil))))) (defun lambda-list-arguments (lambda-list) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys auxargs varest-p) @@ -526,12 +514,11 @@ if (seen_bad_keyword) :aux-p nil ; aux-p; unused here :va-rest-p (if (eq rest-type 'core:&va-rest) t nil))))) -;;; Main entry point. Called for effect. +;;; Main entry point. Returns the parsed arguments, i.e. a list of LLVM Values +;;; appropriate for the corresponding main function call. (But they're not cast.) (defun compile-lambda-list-code (cleavir-lambda-list-analysis xepargs &key (safep t) rest-alloc (fname (clasp-cleavir::%nil))) - "Return T if arguments were processed and NIL if they were not" - (cmp-log "about to compile-lambda-list-code cleavir-lambda-list-analysis: {}%N" cleavir-lambda-list-analysis) (multiple-value-bind (reqargs optargs rest-var key-flag keyargs allow-other-keys unused-auxs varest-p) (process-cleavir-lambda-list-analysis cleavir-lambda-list-analysis) (declare (ignore unused-auxs)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 93b9a64c7c..961253b3d1 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1794,46 +1794,48 @@ (cmp:with-landing-pad nil (let* ((args (llvm-sys:get-argument-list the-function)) (closure-vec (first args)) - (analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group))) - (cmp:compile-lambda-list-code - analysis - (if (eq arity :general-entry) - (make-instance 'cmp::general-xep-arguments - :array (third args) :nargs (second args)) - (make-instance 'cmp::fixed-xep-arguments - :arguments (rest args))) - :fname closure-vec :rest-alloc (compute-rest-alloc analysis)) - ;; Import cells. - (let* ((llvm-function-info (find-llvm-function-info ir)) - (environment-values - (loop for import in (environment llvm-function-info) - for i from 0 - for offset = (cmp:%closure%.offset-of[n]/t* i) - when import ; skip unused fixed closure entries - collect (cmp:irc-t*-load-atomic - (cmp::gen-memref-address closure-vec offset)))) - ;; Tail call the real function. - (function-type (llvm-sys:get-function-type (main-function llvm-function-info))) - (arguments - (mapcar (lambda (arg) - (translate-cast (in arg) - '(:object) (cc-bmir:rtype arg))) - (arguments llvm-function-info))) - (c - (cmp:irc-create-call-wft - function-type - (main-function llvm-function-info) - ;; Augment the environment lexicals as a local call would. - (nconc environment-values arguments))) - (returni (bir:returni ir)) - (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) - #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) - ;; Box/etc. results of the local call. - (if returni - (cmp:irc-ret (translate-cast - (local-call-rv->inputs c rrtype) - rrtype :multiple-values)) - (cmp:irc-unreachable)))))) + (analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) + (uncast-arguments + (cmp:compile-lambda-list-code + analysis + (if (eq arity :general-entry) + (make-instance 'cmp::general-xep-arguments + :array (third args) :nargs (second args)) + (make-instance 'cmp::fixed-xep-arguments + :arguments (rest args))) + :fname closure-vec :rest-alloc (compute-rest-alloc analysis))) + ;; Import cells. + (llvm-function-info (find-llvm-function-info ir)) + (environment-values + (loop for import in (environment llvm-function-info) + for i from 0 + for offset = (cmp:%closure%.offset-of[n]/t* i) + when import ; skip unused fixed closure entries + collect (cmp:irc-t*-load-atomic + (cmp::gen-memref-address closure-vec offset)))) + ;; Tail call the real function. + (function-type + (llvm-sys:get-function-type (main-function llvm-function-info))) + (arguments + (mapcar (lambda (param arg) + (translate-cast arg '(:object) (cc-bmir:rtype param))) + (arguments llvm-function-info) + uncast-arguments)) + (c + (cmp:irc-create-call-wft + function-type + (main-function llvm-function-info) + ;; Augment the environment lexicals as a local call would. + (nconc environment-values arguments))) + (returni (bir:returni ir)) + (rrtype (and returni (cc-bmir:rtype (bir:input returni))))) + #+(or)(llvm-sys:set-calling-conv c 'llvm-sys:fastcc) + ;; Box/etc. results of the local call. + (if returni + (cmp:irc-ret (translate-cast + (local-call-rv->inputs c rrtype) + rrtype :multiple-values)) + (cmp:irc-unreachable))))) the-function) (defun layout-main-function* (the-function ir @@ -1924,8 +1926,7 @@ (t nil)))) (defun layout-xep-function (xep-arity xep-group function lambda-name abi) - (let* ((*datum-values* (make-hash-table :test #'eq)) - (jit-function-name (jit-function-name lambda-name)) + (let* ((jit-function-name (jit-function-name lambda-name)) (cmp:*current-function-name* jit-function-name) (cmp:*gv-current-function-name* (cmp:module-make-global-string jit-function-name "fn-name"))) From 6fb61582394e9b632f1ee518ecc46ab550c6d93a Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 4 May 2024 10:05:11 -0400 Subject: [PATCH 15/37] Have argument processor handle casting This will be needed to use it for local calls. I skipped &key because I couldn't bear to make that code even crazier. Also, &rest arguments are always boxed, which we could maybe fix at some point. In the future we should probably force suppliedp parameters to be boolean rtype, cos what else would they even be. --- src/lisp/kernel/cleavir/arguments.lisp | 183 +++++++++++++--------- src/lisp/kernel/cleavir/cast.lisp | 162 +++++++++++++++++++ src/lisp/kernel/cleavir/clasp-cleavir.asd | 1 + src/lisp/kernel/cleavir/translate.lisp | 163 +------------------ 4 files changed, 274 insertions(+), 235 deletions(-) create mode 100644 src/lisp/kernel/cleavir/cast.lisp diff --git a/src/lisp/kernel/cleavir/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp index 2b9ddd8944..ea4e9c4d65 100644 --- a/src/lisp/kernel/cleavir/arguments.lisp +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -76,7 +76,9 @@ ;; reqargs is as returned from process-lambda-list- (# ...) where # is the count. (loop for i from 0 for req in (rest reqargs) ; maybe use for naming? - collect (nth-arg xepargs i))) + for arg = (nth-arg xepargs i) + for vrtype = (first (clasp-cleavir-bmir::rtype req)) + collect (clasp-cleavir::cast-one :object vrtype arg))) (defgeneric compile-optional-arguments (xepargs optargs nreq false true)) (defmethod compile-optional-arguments ((xepargs general-xep-arguments) @@ -99,18 +101,22 @@ switch (nargs) { (nfixed (+ nopt nreq)) (opts (rest optargs)) (enough (irc-basic-block-create "enough-for-optional")) - (undef (irc-undef-value-get %t*%)) (sw (irc-switch nargs enough nopt)) (assn (irc-basic-block-create "optional-assignments")) (final (irc-basic-block-create "done-parsing-optionals"))) ;; We generate the assignments first, although they occur last. ;; It's just a bit more convenient to do that way. (irc-begin-block assn) - (let ((npreds (1+ nopt)) - (var-phis nil) (suppliedp-phis nil)) - (dotimes (i nopt) - (push (irc-phi %t*% npreds) suppliedp-phis) - (push (irc-phi %t*% npreds) var-phis)) + (multiple-value-bind (var-phis suppliedp-phis) + (loop with npreds = (1+ nopt) + for (var suppliedp) on opts by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for suppliedp-ltype = (clasp-cleavir::vrtype->llvm suppliedp-rtype) + collect (irc-phi var-ltype npreds) into var-phis + collect (irc-phi suppliedp-ltype npreds) into suppliedp-phis + finally (return (values var-phis suppliedp-phis))) (irc-br final) ;; Generate a block for each case. (do ((i nreq (1+ i))) @@ -119,20 +125,40 @@ switch (nargs) { (llvm-sys:add-case sw (irc-size_t i) new) (irc-begin-block new) ;; Assign each optional parameter accordingly. - (loop for var-phi in var-phis + (loop for (var suppliedp) on opts by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir::rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for var-phi in var-phis for suppliedp-phi in suppliedp-phis for j from nreq for enough = (< j i) - do (irc-phi-add-incoming suppliedp-phi (if enough true false) new) - (irc-phi-add-incoming var-phi (if enough (nth-arg xepargs i) undef) new)) + for sp = (ecase suppliedp-rtype + (:object (if enough true false)) + (:boolean (jit-constant-i1 (if enough 1 0)))) + for val = (if enough + (clasp-cleavir::cast-one :object var-rtype + (nth-arg xepargs j)) + (llvm-sys:undef-value-get var-ltype)) + do (irc-phi-add-incoming suppliedp-phi sp new) + (irc-phi-add-incoming var-phi val new)) (irc-br assn))) ;; Default case: everything gets a value and a suppliedp=T. (irc-begin-block enough) - (dolist (suppliedp-phi suppliedp-phis) - (irc-phi-add-incoming suppliedp-phi true enough)) - (loop for var-phi in var-phis + (loop for (var suppliedp) on opts by #'cdddr + for var-phi in var-phis + for suppliedp-phi in suppliedp-phis for i from nreq - do (irc-phi-add-incoming var-phi (nth-arg xepargs i) enough)) + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) + for val = (clasp-cleavir::cast-one :object var-rtype + (nth-arg xepargs i)) + do (irc-phi-add-incoming var-phi val enough) + (irc-phi-add-incoming suppliedp-phi + (ecase suppliedp-rtype + (:object true) + (:boolean (jit-constant-i1 1))) + enough)) (irc-br assn) ;; ready to generate more code (irc-begin-block final) @@ -146,34 +172,49 @@ switch (nargs) { ;; Specific case: Argcount is known. Optional processing is basically ;; trivial in this circumstance. (loop with args = (nthcdr nreq (xep-arguments xepargs)) - with undef = (irc-undef-value-get %t*%) for (var suppliedp) on (rest optargs) by #'cdddr + for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) + for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) for arg = (pop args) - for val = (if (null arg) undef arg) - for sp = (if (null arg) false true) + for val = (if (null arg) + (llvm-sys:undef-value-get + (clasp-cleavir::vrtype->llvm var-rtype)) + (clasp-cleavir::cast-one :object var-rtype arg)) + for sp = (ecase suppliedp-rtype + (:object (if (null arg) false true)) + (:boolean (jit-constant-i1 (if (null arg) 0 1)))) collect val collect sp)) (defun compile-rest-argument (rest-var varest-p rest-alloc args nremaining) - (declare (ignore rest-var)) ; old, maybe use for label name later? - (cmp:irc-branch-to-and-begin-block (cmp:irc-basic-block-create "process-rest-argument")) - (list - (cond ((eq rest-alloc 'ignore) - ;; &rest variable is ignored- allocate nothing - (irc-undef-value-get %t*%)) - ((eq rest-alloc 'dynamic-extent) - ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. - (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) - (irc-intrinsic "cc_gatherDynamicExtentRestArguments" - args nremaining - (irc-bit-cast rrest %t**%)))) - (varest-p - (let ((temp-vaslist (alloca-vaslist :label "rest"))) - (irc-intrinsic "cc_gatherVaRestArguments" - args nremaining temp-vaslist))) - (t - ;; general case- heap allocation - (irc-intrinsic "cc_gatherRestArguments" - args nremaining))))) + (cmp:irc-branch-to-and-begin-block + (cmp:irc-basic-block-create "process-rest-argument")) + (let ((rtype (first (clasp-cleavir-bmir:rtype rest-var)))) + (list + (cond ((eq rest-alloc 'ignore) + ;; &rest variable is ignored- allocate nothing + (irc-undef-value-get (clasp-cleavir::vrtype->llvm rtype))) + ((eq rest-alloc 'dynamic-extent) + ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. + (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) + (clasp-cleavir::cast-one + :object rtype + (irc-intrinsic "cc_gatherDynamicExtentRestArguments" + args nremaining + (irc-bit-cast rrest %t**%))))) + (varest-p + (ecase rtype + (:vaslist + (irc-make-vaslist nremaining args "va-rest-arg")) + (:object + (irc-intrinsic "cc_gatherVaRestArguments" + args nremaining (alloca-vaslist :label "rest"))))) + (t + ;; general case- heap allocation + (clasp-cleavir::cast-one + :object rtype + (irc-intrinsic "cc_gatherRestArguments" + args nremaining))))))) #| Keyword processing is the most complicated part, unsurprisingly. @@ -267,18 +308,18 @@ if (seen_bad_keyword) (irc-phi-add-incoming nargs-remaining nremaining start) (irc-phi-add-incoming sbkw (jit-constant-false) start) (irc-phi-add-incoming bad-keyword undef start) - (do-keys (key) - (let ((var-phi (irc-phi %t*% 2 (core:fmt nil "{}-top" (string key))))) - (push var-phi top-param-phis) - ;; If we're paying attention to :allow-other-keys, track it specially - ;; and initialize it to NIL. - (cond ((and (not lambda-list-aokp) (eq key :allow-other-keys)) - (irc-phi-add-incoming var-phi false start) - (setf allow-other-keys var-phi)) - (t (irc-phi-add-incoming var-phi undef start)))) - (let ((suppliedp-phi (irc-phi %t*% 2 (core:fmt nil "{}-suppliedp-top" (string key))))) - (push suppliedp-phi top-suppliedp-phis) - (irc-phi-add-incoming suppliedp-phi false start))) + (loop for (key) on (cdr keyargs) by #'cddddr + for var-phi = (irc-phi %t*% 2 (format nil "~a-top" key)) + for suppliedp-phi = (irc-phi %t*% 2 (format nil "~s-suppliedp-top" key)) + do (push var-phi top-param-phis) + (push suppliedp-phi top-suppliedp-phis) + ;; If we're paying attention to :allow-other-keys, track it specially + ;; and initialize it to NIL. + (cond ((and (not lambda-list-aokp) (eq key :allow-other-keys)) + (irc-phi-add-incoming var-phi false start) + (setf allow-other-keys var-phi)) + (t (irc-phi-add-incoming var-phi undef start))) + (irc-phi-add-incoming suppliedp-phi false start)) (setf top-param-phis (nreverse top-param-phis) top-suppliedp-phis (nreverse top-suppliedp-phis)) ;; Are we done? @@ -317,30 +358,26 @@ if (seen_bad_keyword) (irc-phi-add-incoming bot-sbkw sbkw new-block) (irc-phi-add-incoming bot-bad-keyword bad-keyword new-block))) ;; OK now the actual keyword values. - (do* ((var-new-blocks new-blocks (cdr var-new-blocks)) - (var-new-block (car var-new-blocks) (car var-new-blocks)) - (top-param-phis top-param-phis (cdr top-param-phis)) - (top-param-phi (car top-param-phis) (car top-param-phis)) - (top-suppliedp-phis top-suppliedp-phis (cdr top-suppliedp-phis)) - (top-suppliedp-phi (car top-suppliedp-phis) (car top-suppliedp-phis))) - ((endp var-new-blocks)) - (let ((var-phi (irc-phi %t*% npreds)) - (suppliedp-phi (irc-phi %t*% npreds))) - ;; fix up the top part to take values from here - (irc-phi-add-incoming top-param-phi var-phi kw-loop-continue) - (irc-phi-add-incoming top-suppliedp-phi suppliedp-phi kw-loop-continue) - ;; If coming from unknown-kw we keep our values the same. - (irc-phi-add-incoming var-phi top-param-phi unknown-kw) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi unknown-kw) - ;; All new-blocks other than this key's stick with what they have. - (dolist (new-block new-blocks) - (cond ((eq var-new-block new-block) - ;; Here, however, we get the new values - (irc-phi-add-incoming var-phi value-arg new-block) - (irc-phi-add-incoming suppliedp-phi true new-block)) - (t - (irc-phi-add-incoming var-phi top-param-phi new-block) - (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block)))))))) + (loop for var-new-block in new-blocks + for top-param-phi in top-param-phis + for top-suppliedp-phi in top-suppliedp-phis + for var-phi = (irc-phi %t*% npreds) + for suppliedp-phi = (irc-phi %t*% npreds) + ;; fix up the top part to take values from here + do (irc-phi-add-incoming top-param-phi var-phi kw-loop-continue) + (irc-phi-add-incoming top-suppliedp-phi suppliedp-phi kw-loop-continue) + ;; If coming from unknown-kw we keep our values the same. + (irc-phi-add-incoming var-phi top-param-phi unknown-kw) + (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi unknown-kw) + ;; All new-blocks other than this key's stick with what they have. + (dolist (new-block new-blocks) + (cond ((eq var-new-block new-block) + ;; Here, however, we get the new values + (irc-phi-add-incoming var-phi value-arg new-block) + (irc-phi-add-incoming suppliedp-phi true new-block)) + (t + (irc-phi-add-incoming var-phi top-param-phi new-block) + (irc-phi-add-incoming suppliedp-phi top-suppliedp-phi new-block))))))) (let ((dec (irc-sub nargs-remaining (irc-size_t 2)))) (irc-phi-add-incoming nargs-remaining dec kw-loop-continue)) (irc-br kw-loop) diff --git a/src/lisp/kernel/cleavir/cast.lisp b/src/lisp/kernel/cleavir/cast.lisp new file mode 100644 index 0000000000..802d4287ee --- /dev/null +++ b/src/lisp/kernel/cleavir/cast.lisp @@ -0,0 +1,162 @@ +(in-package #:clasp-cleavir) + +;;; Given an LLVM Value, its rtype, and a desired rtype, generate code to +;;; convert the value to the desired rtype. +(defun translate-cast (inputv inputrt outputrt) + ;; most of this is special casing crap due to 1-value values not being + ;; passed around as lists. + (cond ((eq inputrt :multiple-values) + (cond ((eq outputrt :multiple-values) + ;; A NOP like this isn't generated within code, but the + ;; translate-cast in layout-xep can end up here. + inputv) + ((not (listp outputrt)) (error "BUG: Bad rtype ~a" outputrt)) + ((= (length outputrt) 1) + (cast-one :object (first outputrt) + (cmp:irc-tmv-primary inputv))) + ((null outputrt) nil) + (t (cons (cast-one :object (first outputrt) + (cmp:irc-tmv-primary inputv)) + (loop for i from 1 + for ort in (rest outputrt) + for val = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object ort val)))))) + ((eq inputrt :vaslist) + (cond ((eq outputrt :multiple-values) + (%intrinsic-call "cc_load_values" + (list (cmp:irc-vaslist-nvals inputv) + (cmp:irc-vaslist-values inputv)))) + ((and (listp outputrt) (= (length outputrt) 1)) + (cast-one :object (first outputrt) + (cmp:irc-vaslist-nth (%size_t 0) inputv))) + (t (error "BUG: Cast from ~a to ~a" inputrt outputrt)))) + ((not (listp inputrt)) (error "BUG: Bad rtype ~a" inputrt)) + ;; inputrt must be a list (fixed values) + ((= (length inputrt) 1) + (cond ((eq outputrt :multiple-values) + (cmp:irc-make-tmv (%size_t 1) + (cast-one (first inputrt) :object inputv))) + ((not (listp outputrt)) + (error "BUG: Cast from ~a to ~a" inputrt outputrt)) + ((null outputrt) nil) + ((= (length outputrt) 1) + (cast-one (first inputrt) (first outputrt) inputv)) + (t ;; pad with nil + (assert (every (lambda (r) (eq r :object)) (rest outputrt))) + (cons (cast-one (first inputrt) (first outputrt) inputv) + (loop repeat (length (rest outputrt)) + collect (%nil)))))) + (t + (cond ((eq outputrt :multiple-values) + (%cast-to-mv + (loop for inv in inputv for irt in inputrt + collect (cast-one irt :object inv)))) + ((not (listp outputrt)) + (error "BUG: Cast from ~a to ~a" inputrt outputrt)) + ((= (length outputrt) 1) + (cond ((null inputrt) + (ecase (first outputrt) + ((:object) (%nil)) + ;; We can end up here with a variety of output vrtypes + ;; in some unusual situations where a primop expects + ;; a value, but control will never actually reach it. + ;; Ideally the compiler would not bother compiling + ;; such unreachable code, but sometimes it's stupid. + ((:fixnum) (llvm-sys:undef-value-get cmp:%fixnum%)) + ((:single-float) + (llvm-sys:undef-value-get cmp:%float%)) + ((:double-float) + (llvm-sys:undef-value-get cmp:%double%)))) + (t + (cast-one (first inputrt) (first outputrt) + (first inputv))))) + (t (%cast-some inputrt outputrt inputv)))))) + +;;; Given a list of Values, generate code to return it as multiple (Lisp) values. +(defun %cast-to-mv (values) + (cond ((null values) (cmp:irc-make-tmv (%size_t 0) (%nil))) + (t + (loop for i from 1 for v in (rest values) + do (cmp:irc-store v (return-value-elt i))) + (cmp:irc-make-tmv (%size_t (length values)) (first values))))) + +;;; Generate code to cast the Value from the given vrtype to the desired. +(defgeneric cast-one (from to value) + (:method (from to value) + (if (eql from to) + value + (error "BUG: Don't know how to cast ~a ~a to ~a" from value to)))) + +(defmethod cast-one ((from (eql :boolean)) (to (eql :object)) value) + ;; we could use a select instruction, but then we'd have a redundant memory load. + ;; which really shouldn't be a big deal, but why risk it. + (let* ((thenb (cmp:irc-basic-block-create "bool-t")) + (elseb (cmp:irc-basic-block-create "bool-nil")) + (_0 (cmp:irc-cond-br value thenb elseb)) + (merge (cmp:irc-basic-block-create "bool")) + (_1 (cmp:irc-begin-block merge)) + (phi (cmp:irc-phi cmp:%t*% 2 "bool"))) + (declare (ignore _0 _1)) + (cmp:irc-begin-block thenb) + (cmp:irc-phi-add-incoming phi (%t) thenb) + (cmp:irc-br merge) + (cmp:irc-begin-block elseb) + (cmp:irc-phi-add-incoming phi (%nil) elseb) + (cmp:irc-br merge) + (cmp:irc-begin-block merge) + phi)) + +(defmethod cast-one ((from (eql :object)) (to (eql :boolean)) value) + (cmp:irc-icmp-ne value (%nil))) + +(defmethod cast-one ((from (eql :single-float)) (to (eql :object)) value) + (cmp:irc-box-single-float value)) +(defmethod cast-one ((from (eql :object)) (to (eql :single-float)) value) + (cmp:irc-unbox-single-float value)) + +(defmethod cast-one ((from (eql :double-float)) (to (eql :object)) value) + (cmp:irc-box-double-float value)) +(defmethod cast-one ((from (eql :object)) (to (eql :double-float)) value) + (cmp:irc-unbox-double-float value)) + +(defmethod cast-one ((from (eql :base-char)) (to (eql :object)) value) + (cmp:irc-tag-base-char value)) +(defmethod cast-one ((from (eql :object)) (to (eql :base-char)) value) + (cmp:irc-untag-base-char value)) +(defmethod cast-one ((from (eql :character)) (to (eql :object)) value) + (cmp:irc-tag-character value)) +(defmethod cast-one ((from (eql :object)) (to (eql :character)) value) + (cmp:irc-untag-character value)) + +(defmethod cast-one ((from (eql :base-char)) (to (eql :character)) value) + (cmp:irc-zext value cmp:%i32%)) +(defmethod cast-one ((from (eql :character)) (to (eql :base-char)) value) + (cmp:irc-trunc value cmp:%i8%)) + +(defmethod cast-one ((from (eql :fixnum)) (to (eql :object)) value) + (cmp:irc-int-to-ptr value cmp:%t*%)) +(defmethod cast-one ((from (eql :object)) (to (eql :fixnum)) value) + (cmp:irc-ptr-to-int value cmp:%fixnum%)) + +(defmethod cast-one ((from (eql :utfixnum)) (to (eql :fixnum)) value) + (cmp:irc-shl value cmp:+fixnum-shift+ :nsw t)) +(defmethod cast-one ((from (eql :fixnum)) (to (eql :utfixnum)) value) + (cmp:irc-ashr value cmp:+fixnum-shift+ :exact t)) + +(defmethod cast-one ((from (eql :utfixnum)) (to (eql :object)) value) + (cmp:irc-tag-fixnum value)) +(defmethod cast-one ((from (eql :object)) (to (eql :utfixnum)) value) + (cmp:irc-untag-fixnum value cmp:%fixnum%)) + +(defmethod cast-one ((from (eql :object)) (to (eql :vaslist)) value) + ;; We only generate these when we know for sure the input is a vaslist, + ;; so we don't do checking. + (cmp:irc-unbox-vaslist value)) + +(defun %cast-some (inputrt outputrt inputv) + (let ((Lin (length inputrt)) (Lout (length outputrt)) + (pref (mapcar #'cast-one inputrt outputrt inputv))) + (cond ((<= Lout Lin) pref) + (t + (assert (every (lambda (r) (eq r :object)) (subseq outputrt Lin))) + (nconc pref (loop repeat (- Lout Lin) collect (%nil))))))) diff --git a/src/lisp/kernel/cleavir/clasp-cleavir.asd b/src/lisp/kernel/cleavir/clasp-cleavir.asd index d575e8d254..88122ca690 100644 --- a/src/lisp/kernel/cleavir/clasp-cleavir.asd +++ b/src/lisp/kernel/cleavir/clasp-cleavir.asd @@ -28,6 +28,7 @@ (:file "ir") (:file "jit") (:file "translation-environment") + (:file "cast") (:file "arguments") (:file "bir") (:file "bmir") diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 961253b3d1..6d0ca86122 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1099,92 +1099,6 @@ (out (if (= ninputs 1) (in (first inputs)) (mapcar #'in inputs)) output))))) -(defun %cast-to-mv (values) - (cond ((null values) (cmp:irc-make-tmv (%size_t 0) (%nil))) - (t - (loop for i from 1 for v in (rest values) - do (cmp:irc-store v (return-value-elt i))) - (cmp:irc-make-tmv (%size_t (length values)) (first values))))) - -(defgeneric cast-one (from to value) - (:method (from to value) - (if (eql from to) - value - (error "BUG: Don't know how to cast ~a ~a to ~a" from value to)))) - -(defmethod cast-one ((from (eql :boolean)) (to (eql :object)) value) - ;; we could use a select instruction, but then we'd have a redundant memory load. - ;; which really shouldn't be a big deal, but why risk it. - (let* ((thenb (cmp:irc-basic-block-create "bool-t")) - (elseb (cmp:irc-basic-block-create "bool-nil")) - (_0 (cmp:irc-cond-br value thenb elseb)) - (merge (cmp:irc-basic-block-create "bool")) - (_1 (cmp:irc-begin-block merge)) - (phi (cmp:irc-phi cmp:%t*% 2 "bool"))) - (declare (ignore _0 _1)) - (cmp:irc-begin-block thenb) - (cmp:irc-phi-add-incoming phi (%t) thenb) - (cmp:irc-br merge) - (cmp:irc-begin-block elseb) - (cmp:irc-phi-add-incoming phi (%nil) elseb) - (cmp:irc-br merge) - (cmp:irc-begin-block merge) - phi)) -(defmethod cast-one ((from (eql :object)) (to (eql :boolean)) value) - (cmp:irc-icmp-ne value (%nil))) - -(defmethod cast-one ((from (eql :single-float)) (to (eql :object)) value) - (cmp:irc-box-single-float value)) -(defmethod cast-one ((from (eql :object)) (to (eql :single-float)) value) - (cmp:irc-unbox-single-float value)) - -(defmethod cast-one ((from (eql :double-float)) (to (eql :object)) value) - (cmp:irc-box-double-float value)) -(defmethod cast-one ((from (eql :object)) (to (eql :double-float)) value) - (cmp:irc-unbox-double-float value)) - -(defmethod cast-one ((from (eql :base-char)) (to (eql :object)) value) - (cmp:irc-tag-base-char value)) -(defmethod cast-one ((from (eql :object)) (to (eql :base-char)) value) - (cmp:irc-untag-base-char value)) -(defmethod cast-one ((from (eql :character)) (to (eql :object)) value) - (cmp:irc-tag-character value)) -(defmethod cast-one ((from (eql :object)) (to (eql :character)) value) - (cmp:irc-untag-character value)) - -(defmethod cast-one ((from (eql :base-char)) (to (eql :character)) value) - (cmp:irc-zext value cmp:%i32%)) -(defmethod cast-one ((from (eql :character)) (to (eql :base-char)) value) - (cmp:irc-trunc value cmp:%i8%)) - -(defmethod cast-one ((from (eql :fixnum)) (to (eql :object)) value) - (cmp:irc-int-to-ptr value cmp:%t*%)) -(defmethod cast-one ((from (eql :object)) (to (eql :fixnum)) value) - (cmp:irc-ptr-to-int value cmp:%fixnum%)) - -(defmethod cast-one ((from (eql :utfixnum)) (to (eql :fixnum)) value) - (cmp:irc-shl value cmp:+fixnum-shift+ :nsw t)) -(defmethod cast-one ((from (eql :fixnum)) (to (eql :utfixnum)) value) - (cmp:irc-ashr value cmp:+fixnum-shift+ :exact t)) - -(defmethod cast-one ((from (eql :utfixnum)) (to (eql :object)) value) - (cmp:irc-tag-fixnum value)) -(defmethod cast-one ((from (eql :object)) (to (eql :utfixnum)) value) - (cmp:irc-untag-fixnum value cmp:%fixnum%)) - -(defmethod cast-one ((from (eql :object)) (to (eql :vaslist)) value) - ;; We only generate these when we know for sure the input is a vaslist, - ;; so we don't do checking. - (cmp:irc-unbox-vaslist value)) - -(defun %cast-some (inputrt outputrt inputv) - (let ((Lin (length inputrt)) (Lout (length outputrt)) - (pref (mapcar #'cast-one inputrt outputrt inputv))) - (cond ((<= Lout Lin) pref) - (t - (assert (every (lambda (r) (eq r :object)) (subseq outputrt Lin))) - (nconc pref (loop repeat (- Lout Lin) collect (%nil))))))) - (define-condition box-emitted (ext:compiler-note) ((%name :initarg :name :reader name) (%inputrt :initarg :inputrt :reader inputrt) @@ -1213,76 +1127,6 @@ :inputrt inputrt :outputrt outputrt :name name :origin (origin-source origin)))) -(defun translate-cast (inputv inputrt outputrt) - ;; most of this is special casing crap due to 1-value values not being - ;; passed around as lists. - (cond ((eq inputrt :multiple-values) - (cond ((eq outputrt :multiple-values) - ;; A NOP like this isn't generated within code, but the - ;; translate-cast in layout-xep can end up here. - inputv) - ((not (listp outputrt)) (error "BUG: Bad rtype ~a" outputrt)) - ((= (length outputrt) 1) - (cast-one :object (first outputrt) - (cmp:irc-tmv-primary inputv))) - ((null outputrt) nil) - (t (cons (cast-one :object (first outputrt) - (cmp:irc-tmv-primary inputv)) - (loop for i from 1 - for ort in (rest outputrt) - for val = (cmp:irc-t*-load (return-value-elt i)) - collect (cast-one :object ort val)))))) - ((eq inputrt :vaslist) - (cond ((eq outputrt :multiple-values) - (%intrinsic-call "cc_load_values" - (list (cmp:irc-vaslist-nvals inputv) - (cmp:irc-vaslist-values inputv)))) - ((and (listp outputrt) (= (length outputrt) 1)) - (cast-one :object (first outputrt) - (cmp:irc-vaslist-nth (%size_t 0) inputv))) - (t (error "BUG: Cast from ~a to ~a" inputrt outputrt)))) - ((not (listp inputrt)) (error "BUG: Bad rtype ~a" inputrt)) - ;; inputrt must be a list (fixed values) - ((= (length inputrt) 1) - (cond ((eq outputrt :multiple-values) - (cmp:irc-make-tmv (%size_t 1) - (cast-one (first inputrt) :object inputv))) - ((not (listp outputrt)) - (error "BUG: Cast from ~a to ~a" inputrt outputrt)) - ((null outputrt) nil) - ((= (length outputrt) 1) - (cast-one (first inputrt) (first outputrt) inputv)) - (t ;; pad with nil - (assert (every (lambda (r) (eq r :object)) (rest outputrt))) - (cons (cast-one (first inputrt) (first outputrt) inputv) - (loop repeat (length (rest outputrt)) - collect (%nil)))))) - (t - (cond ((eq outputrt :multiple-values) - (%cast-to-mv - (loop for inv in inputv for irt in inputrt - collect (cast-one irt :object inv)))) - ((not (listp outputrt)) - (error "BUG: Cast from ~a to ~a" inputrt outputrt)) - ((= (length outputrt) 1) - (cond ((null inputrt) - (ecase (first outputrt) - ((:object) (%nil)) - ;; We can end up here with a variety of output vrtypes - ;; in some unusual situations where a primop expects - ;; a value, but control will never actually reach it. - ;; Ideally the compiler would not bother compiling - ;; such unreachable code, but sometimes it's stupid. - ((:fixnum) (llvm-sys:undef-value-get cmp:%fixnum%)) - ((:single-float) - (llvm-sys:undef-value-get cmp:%float%)) - ((:double-float) - (llvm-sys:undef-value-get cmp:%double%)))) - (t - (cast-one (first inputrt) (first outputrt) - (first inputv))))) - (t (%cast-some inputrt outputrt inputv)))))) - (defmethod translate-simple-instruction ((instr cc-bmir:cast) (abi abi-x86-64)) (let* ((input (bir:input instr)) (inputrt (cc-bmir:rtype input)) (output (bir:output instr)) (outputrt (cc-bmir:rtype output))) @@ -1795,7 +1639,7 @@ (let* ((args (llvm-sys:get-argument-list the-function)) (closure-vec (first args)) (analysis (cmp:xep-group-cleavir-lambda-list-analysis xep-group)) - (uncast-arguments + (arguments (cmp:compile-lambda-list-code analysis (if (eq arity :general-entry) @@ -1816,11 +1660,6 @@ ;; Tail call the real function. (function-type (llvm-sys:get-function-type (main-function llvm-function-info))) - (arguments - (mapcar (lambda (param arg) - (translate-cast arg '(:object) (cc-bmir:rtype param))) - (arguments llvm-function-info) - uncast-arguments)) (c (cmp:irc-create-call-wft function-type From 6bc98e2fe599fb58a0540bf0f363c6399930e65f Mon Sep 17 00:00:00 2001 From: Bike Date: Sat, 4 May 2024 20:43:12 -0400 Subject: [PATCH 16/37] No more separate argument processing for local calls Unifying this makes translate much less messy with all that duplicate code, and makes it possible to local call anything, including functions with &rest and/or &key parameters. Also means we don't have to allocate a closure for local calls ever - that was super dumb and I'm disappointed in myself for ever thinking it was a good idea. Argument parsing for local calls is moved into the caller in all cases now. That may be a bit suboptimal for local functions that are called in more than one place, since the parsing code is duplicated. I really doubt that will be a big deal except _maybe_ for functions with &key, since key parsing is actually a fair bit of code. But &key functions are already kind of doomed as far as optimization goes, and local functions that are called in multiple places are rare to begin with (only arising from flet/labels, versus the much more common type checkers and m-v-bind lambdas) so I'm not too worried. The Right Thing To Do long term is probably to do as karlosz suggested years ago and represent XEPs explicitly in the IR. A shorter term fix would be to create pseudo-XEPs for these functions - "pseudo" in that they would parse arbitrary arguments, but take the environment as individual arguments instead of as an allocated closure. --- src/lisp/kernel/cleavir/arguments.lisp | 32 ++- src/lisp/kernel/cleavir/translate.lisp | 316 ++++--------------------- 2 files changed, 75 insertions(+), 273 deletions(-) diff --git a/src/lisp/kernel/cleavir/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp index ea4e9c4d65..162d85bead 100644 --- a/src/lisp/kernel/cleavir/arguments.lisp +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -7,7 +7,8 @@ ((%array :initarg :array :reader xep-array) (%nargs :initarg :nargs :reader xep-nargs))) (defclass fixed-xep-arguments (xep-arguments) - ((%arguments :initarg :arguments :reader xep-arguments))) + ((%arguments :initarg :arguments :reader xep-arguments) + (%vrtypes :initarg :vrtypes :reader xep-vrtypes))) (defmethod xep-nargs ((arguments fixed-xep-arguments)) (irc-size_t (length (xep-arguments arguments)))) @@ -21,6 +22,15 @@ (defmethod nth-arg ((args fixed-xep-arguments) n) (nth n (xep-arguments args))) +;;; Get the vrtype for the nth argument. +(defgeneric nth-vrtype (arguments n)) +(defmethod nth-vrtype ((args general-xep-arguments) n) + ;; rest arguments are always boxed at the moment. + (declare (ignore n)) + :object) +(defmethod nth-vrtype ((args fixed-xep-arguments) n) + (nth n (xep-vrtypes args))) + ;;; Generate code to get the arguments starting with the nth as an array. ;;; n is a constant (i.e. a Lisp integer). (defgeneric remaining-args (args n)) @@ -40,10 +50,12 @@ (let ((res (alloca %t*% size))) ;; Fill it up. (loop for arg in (nthcdr n vals) + for vrt in (nthcdr n (xep-vrtypes args)) + for cast = (clasp-cleavir::cast-one vrt :object arg) for i from 0 for addr = (irc-typed-gep (llvm-sys:array-type-get %t*% 0) - res (list i)) - do (irc-store arg addr)) + res (list 0 i)) + do (irc-store cast addr)) res)))) (defun compile-wrong-number-arguments-block (fname nargs min max) @@ -77,8 +89,9 @@ (loop for i from 0 for req in (rest reqargs) ; maybe use for naming? for arg = (nth-arg xepargs i) - for vrtype = (first (clasp-cleavir-bmir::rtype req)) - collect (clasp-cleavir::cast-one :object vrtype arg))) + for src-vrtype = (nth-vrtype xepargs i) + for dest-vrtype = (first (clasp-cleavir-bmir::rtype req)) + collect (clasp-cleavir::cast-one src-vrtype dest-vrtype arg))) (defgeneric compile-optional-arguments (xepargs optargs nreq false true)) (defmethod compile-optional-arguments ((xepargs general-xep-arguments) @@ -133,11 +146,12 @@ switch (nargs) { for suppliedp-phi in suppliedp-phis for j from nreq for enough = (< j i) + for src-vrtype = (nth-vrtype xepargs j) for sp = (ecase suppliedp-rtype (:object (if enough true false)) (:boolean (jit-constant-i1 (if enough 1 0)))) for val = (if enough - (clasp-cleavir::cast-one :object var-rtype + (clasp-cleavir::cast-one src-vrtype var-rtype (nth-arg xepargs j)) (llvm-sys:undef-value-get var-ltype)) do (irc-phi-add-incoming suppliedp-phi sp new) @@ -150,8 +164,9 @@ switch (nargs) { for suppliedp-phi in suppliedp-phis for i from nreq for var-rtype = (first (clasp-cleavir-bmir:rtype var)) + for src-vrtype = (nth-vrtype xepargs i) for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) - for val = (clasp-cleavir::cast-one :object var-rtype + for val = (clasp-cleavir::cast-one src-vrtype var-rtype (nth-arg xepargs i)) do (irc-phi-add-incoming var-phi val enough) (irc-phi-add-incoming suppliedp-phi @@ -172,6 +187,7 @@ switch (nargs) { ;; Specific case: Argcount is known. Optional processing is basically ;; trivial in this circumstance. (loop with args = (nthcdr nreq (xep-arguments xepargs)) + with src-vrtypes = (nthcdr nreq (xep-vrtypes xepargs)) for (var suppliedp) on (rest optargs) by #'cdddr for var-rtype = (first (clasp-cleavir-bmir:rtype var)) for var-ltype = (clasp-cleavir::vrtype->llvm var-rtype) @@ -180,7 +196,7 @@ switch (nargs) { for val = (if (null arg) (llvm-sys:undef-value-get (clasp-cleavir::vrtype->llvm var-rtype)) - (clasp-cleavir::cast-one :object var-rtype arg)) + (clasp-cleavir::cast-one (pop src-vrtypes) var-rtype arg)) for sp = (ecase suppliedp-rtype (:object (if (null arg) false true)) (:boolean (jit-constant-i1 (if (null arg) 0 1)))) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 6d0ca86122..23f858f5b0 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -17,34 +17,8 @@ (%xep-function-description :initarg :xep-function-description :reader xep-function-description) (%main-function :initarg :main-function :reader main-function))) -(defun lambda-list-too-hairy-p (lambda-list) - (multiple-value-bind (reqargs optargs rest-var key-flag keyargs aok aux varest-p) - (cmp:process-bir-lambda-list lambda-list) - (declare (ignore reqargs optargs keyargs aok aux rest-var varest-p)) - key-flag)) - -(defun nontrivial-mv-local-call-p (call) - (cond ((typep call 'cc-bmir:fixed-mv-local-call) - ;; Could still be nontrivial if the number of arguments is wrong - (multiple-value-bind (req opt rest) - (cmp:process-bir-lambda-list (bir:lambda-list (bir:callee call))) - (let ((lreq (length (cc-bmir:rtype (second (bir:inputs call)))))) - (or (< lreq (car req)) - (and (not rest) (> lreq (+ (car req) (car opt)))))))) - ((typep call 'bir:mv-local-call) t) - (t nil))) - (defun xep-needed-p (function) (or (bir:enclose function) - ;; We need a XEP for more involved lambda lists. - (lambda-list-too-hairy-p (bir:lambda-list function)) - ;; or for mv-calls that might need to signal an error. - (and (cleavir-set:some #'nontrivial-mv-local-call-p - (bir:local-calls function)) - (multiple-value-bind (req opt rest) - (cmp:process-bir-lambda-list (bir:lambda-list function)) - (declare (ignore opt)) - (or (plusp (car req)) (not rest)))) ;; Assume that a function with no enclose and no local calls is ;; toplevel and needs an XEP. Else it would have been removed or ;; deleted as it is unreferenced otherwise. @@ -703,62 +677,6 @@ (out (variable-in (bir:input instruction)) (bir:output instruction))) -(defun gen-rest-list (present-arguments) - (if (null present-arguments) - (%nil) - ;; Generate a call to cc_list. - ;; TODO: DX &rest lists. - (%intrinsic-invoke-if-landing-pad-or-call - "cc_list" (list* (%size_t (length present-arguments)) - present-arguments)))) - -(defun maybe-boxed-vaslist (boxp nvals vals) - (let ((vas (cmp:irc-make-vaslist nvals vals))) - (if boxp - (let ((mem (cmp:alloca cmp:%vaslist% 1))) - (cmp:irc-store vas mem) - (cmp:irc-tag-vaslist mem)) - vas))) - -(defun gen-va-rest-list (present-arguments boxp) - (let* ((nargs (length present-arguments)) - ;; nargs is constant, so this alloca is just in the intro block. - (dat (cmp:alloca cmp:%t*% nargs "local-va-rest"))) - ;; Store the arguments into the allocated memory. - (loop for arg in present-arguments - for i from 0 - do (cmp:irc-store arg (cmp:irc-typed-gep cmp:%t*% dat (list i)))) - ;; Make and return the va list object. - (maybe-boxed-vaslist boxp (%size_t nargs) dat))) - -(defun parse-local-call-optional-arguments (opt arguments) - (loop for (op) on (rest opt) by #'cdddr - if arguments - collect (translate-cast (pop arguments) '(:object) - (cc-bmir:rtype op)) - and collect (%t) - else - collect (cmp:irc-undef-value-get (argument-rtype->llvm op)) - and collect (%nil))) - -;; Create than argument list for a local call by parsing the callee's -;; lambda list and filling in the correct values at compile time. We -;; assume that we have already checked the validity of this call. -(defun parse-local-call-arguments (req opt rest rest-vrtype arguments) - (let* ((nreq (car req)) (nopt (car opt)) - (reqargs (subseq arguments 0 nreq)) - (more (nthcdr nreq arguments)) - (optargs (parse-local-call-optional-arguments opt more)) - (rest - (cond ((not rest) nil) - ((eq rest :unused) - (list (cmp:irc-undef-value-get cmp:%t*%))) - ((eq rest :va-rest) - (list (gen-va-rest-list (nthcdr nopt more) - (eq rest-vrtype :object)))) - (t (list (gen-rest-list (nthcdr nopt more))))))) - (append reqargs optargs rest))) - ;;; Get a reference to the literal for a function's simple fun. ;;; This is generic because it's also used by the BTB translator. (defgeneric reference-xep (function function-info)) @@ -818,64 +736,37 @@ :vaslist :object)) -(defun gen-local-call (callee arguments outputrt) - (let ((callee-info (find-llvm-function-info callee))) - (cond ((lambda-list-too-hairy-p (bir:lambda-list callee)) - ;; Has &key or something, so use the normal call protocol. - ;; We allocate a fresh closure for every call. Hopefully this - ;; isn't too expensive. We can always use stack allocation since - ;; there's no possibility of this closure being stored in a closure - ;; (If we local-call a self-referencing closure, the closure cell - ;; will get its value from some enclose. - ;; FIXME we could use that instead?) - (translate-cast (closure-call-or-invoke - (enclose callee :dynamic nil) - arguments) - :multiple-values outputrt)) - (t - ;; Call directly. - (multiple-value-bind (req opt rest-var key-flag keyargs aok aux - varest-p) - (cmp:process-bir-lambda-list (bir:lambda-list callee)) - (declare (ignore keyargs aok aux)) - (assert (not key-flag)) - (let ((largs (length arguments))) - (when (or (< largs (car req)) - (and (not rest-var) - (> largs (+ (car req) (car opt))))) - ;; too many or too few args; we can get here from - ;; fixed-mv-local-calls for instance. - (return-from gen-local-call - (translate-cast (closure-call-or-invoke - (enclose callee :dynamic nil) - arguments) - :multiple-values outputrt)))) - (let* ((rest-id (cond ((null rest-var) nil) - ((bir:unused-p rest-var) :unused) - (varest-p :va-rest) - (t t))) - (rest-vrtype (rest-vrtype rest-var)) - (subargs - (parse-local-call-arguments - req opt rest-id rest-vrtype arguments)) - (args (append (environment-arguments - (environment callee-info)) - subargs)) - (function (main-function callee-info)) - (function-type (llvm-sys:get-function-type function)) - (result-in-registers - (cmp::irc-call-or-invoke function-type function args))) - #+(or) - (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) - (local-call-rv->inputs result-in-registers outputrt))))))) +(defun gen-local-call (callee arguments argrts outputrt) + (let* ((analysis + ;; FIXME: Can be calculated redundantly + (cmp:calculate-cleavir-lambda-list-analysis + (bir:lambda-list callee))) + (callee-info (find-llvm-function-info callee)) + (envargs (environment-arguments (environment callee-info))) + (xepargs (make-instance 'cmp::fixed-xep-arguments + :arguments arguments :vrtypes argrts)) + (subargs (cmp:compile-lambda-list-code + analysis xepargs + :rest-alloc (compute-rest-alloc analysis) + :fname (clasp-cleavir::literal (bir:name callee)))) + (args (append envargs subargs)) + (function (main-function callee-info)) + (function-type (llvm-sys:get-function-type function)) + (result-in-registers + (cmp::irc-call-or-invoke function-type function args))) + #+(or) + (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) + (local-call-rv->inputs result-in-registers outputrt))) (defmethod translate-simple-instruction ((instruction bir:local-call) abi) (declare (ignore abi)) (let* ((callee (bir:callee instruction)) (args (mapcar #'in (rest (bir:inputs instruction)))) + (vrtypes (loop for inp in (rest (bir:inputs instruction)) + collect (first (cc-bmir:rtype inp)))) (output (bir:output instruction)) - (call (gen-local-call callee args (cc-bmir:rtype output)))) + (call (gen-local-call callee args vrtypes (cc-bmir:rtype output)))) (out call output))) (defmethod translate-simple-instruction ((instruction bir:call) abi) @@ -889,144 +780,36 @@ :label (datum-name-as-string output)) output))) -(defun general-mv-local-call-vas (callee vaslist label outputrt) - (translate-cast (cmp:irc-apply (enclose callee :dynamic nil) - (cmp:irc-vaslist-nvals vaslist) - (cmp:irc-vaslist-values vaslist) - label) - :multiple-values outputrt)) - -(defun direct-mv-local-call-vas (vaslist callee req opt rest-var varest-p - label outputrt) - (let* ((callee-info (find-llvm-function-info callee)) - (nreq (car req)) - (nopt (car opt)) - (rnret (cmp:irc-vaslist-nvals vaslist)) - (rvalues (cmp:irc-vaslist-values vaslist)) - (nfixed (+ nreq nopt)) - (mismatch - (unless (and (zerop nreq) rest-var) - (cmp:irc-basic-block-create "lmvc-arg-mismatch"))) - (mte (if rest-var - (cmp:irc-basic-block-create "lmvc-more-than-enough") - mismatch)) - (merge (cmp:irc-basic-block-create "lmvc-after")) - (sw (cmp:irc-switch rnret mte (+ 1 nreq nopt))) - (environment (environment callee-info)) - (rest-vaboxp (not (eq (rest-vrtype rest-var) :vaslist)))) - (labels ((load-return-value (n) - (cmp:irc-t*-load (cmp:irc-typed-gep cmp:%t*% rvalues (list n)))) - (load-return-values (low high) - (loop for i from low below high - collect (load-return-value i))) - (optionals (n) - (parse-local-call-optional-arguments - opt (load-return-values nreq (+ nreq n))))) - ;; Generate phis for the merge block's call. - (cmp:irc-begin-block merge) - (let ((opt-phis - (loop for (op s-p) on (rest opt) by #'cdddr - for op-ty = (argument-rtype->llvm op) - for s-p-ty = (argument-rtype->llvm s-p) - collect (cmp:irc-phi op-ty (1+ nopt)) - collect (cmp:irc-phi s-p-ty (1+ nopt)))) - (rest-phi - (cond ((null rest-var) nil) - ((bir:unused-p rest-var) - (cmp:irc-undef-value-get cmp:%t*%)) - (t (cmp:irc-phi (argument-rtype->llvm rest-var) - (1+ nopt)))))) - ;; Generate the mismatch block, if it exists. - (when mismatch - (cmp:irc-begin-block mismatch) - (cmp::irc-intrinsic-call-or-invoke - "cc_wrong_number_of_arguments" - (list (enclose callee :indefinite nil) rnret - (%size_t nreq) (%size_t nfixed))) - (cmp:irc-unreachable)) - ;; Generate not-enough-args cases. - (loop for i below nreq - do (cmp:irc-add-case sw (%size_t i) mismatch)) - ;; Generate optional arg cases, including the exactly-enough case. - (loop for i upto nopt - for b = (cmp:irc-basic-block-create - (format nil "lmvc-optional-~d" i)) - do (cmp:irc-add-case sw (%size_t (+ nreq i)) b) - (cmp:irc-begin-block b) - (loop for phi in opt-phis - for val in (optionals i) - do (cmp:irc-phi-add-incoming phi val b)) - (when (and rest-var (not (bir:unused-p rest-var))) - (cmp:irc-phi-add-incoming - rest-phi - (if varest-p - (maybe-boxed-vaslist - rest-vaboxp (%size_t 0) - (llvm-sys:constant-pointer-null-get cmp:%t**%)) - (%nil)) - b)) - (cmp:irc-br merge)) - ;; If there's a &rest, generate the more-than-enough arguments case. - (when rest-var - (cmp:irc-begin-block mte) - (loop for phi in opt-phis - for val in (optionals nopt) - do (cmp:irc-phi-add-incoming phi val mte)) - (unless (bir:unused-p rest-var) - (cmp:irc-phi-add-incoming - rest-phi - (if varest-p - (maybe-boxed-vaslist - rest-vaboxp - (cmp:irc-sub rnret (%size_t nfixed)) - (cmp:irc-typed-gep cmp:%t*% rvalues (list nfixed))) - (%intrinsic-invoke-if-landing-pad-or-call - "cc_mvcGatherRest2" - (list (cmp:irc-typed-gep cmp:%t*% rvalues (list nfixed)) - (cmp:irc-sub rnret (%size_t nfixed))))) - mte)) - (cmp:irc-br merge)) - ;; Generate the call, in the merge block. - (cmp:irc-begin-block merge) - (let* ((arguments - (nconc - (environment-arguments environment) - (loop for r in (rest req) - for j from 0 - collect (translate-cast (load-return-value j) '(:object) - (cc-bmir:rtype r))) - opt-phis - (when rest-var (list rest-phi)))) - (function (main-function callee-info)) - (function-type (llvm-sys:get-function-type function)) - (call - (cmp:irc-call-or-invoke function-type function arguments - cmp:*current-unwind-landing-pad-dest* - label))) - #+(or)(llvm-sys:set-calling-conv call 'llvm-sys:fastcc) - (local-call-rv->inputs call outputrt)))))) - (defmethod translate-simple-instruction ((instruction bir:mv-local-call) abi) (declare (ignore abi)) (let* ((output (bir:output instruction)) (outputrt (cc-bmir:rtype output)) - (oname (datum-name-as-string output)) (callee (bir:callee instruction)) (mvarg (second (bir:inputs instruction))) - (mvargrt (cc-bmir:rtype mvarg)) - (mvargi (in mvarg))) - (assert (eq mvargrt :vaslist)) - (out - (multiple-value-bind (req opt rest-var key-flag keyargs - aok aux varest-p) - (cmp::process-bir-lambda-list (bir:lambda-list callee)) - (declare (ignore keyargs aok aux)) - (if key-flag - (general-mv-local-call-vas callee mvargi oname outputrt) - (direct-mv-local-call-vas - mvargi callee req opt rest-var varest-p oname outputrt))) - output))) + (_ (assert (eq :vaslist (cc-bmir:rtype mvarg)))) + (mvargi (in mvarg)) + (analysis + ;; FIXME: Can be calculated redundantly + (cmp:calculate-cleavir-lambda-list-analysis + (bir:lambda-list callee))) + (callee-info (find-llvm-function-info callee)) + (envargs (environment-arguments (environment callee-info))) + (xepargs (make-instance 'cmp::general-xep-arguments + :array (cmp:irc-vaslist-values mvargi) + :nargs (cmp:irc-vaslist-nvals mvargi))) + (subargs (cmp:compile-lambda-list-code + analysis xepargs + :rest-alloc (compute-rest-alloc analysis) + :fname (clasp-cleavir::literal (bir:name callee)))) + (args (append envargs subargs)) + (function (main-function callee-info)) + (function-type (llvm-sys:get-function-type function)) + (result-in-registers + (cmp::irc-call-or-invoke function-type function args))) + (declare (ignore _)) + #+(or) (llvm-sys:set-calling-conv result-in-registers 'llvm-sys:fastcc) + (out (local-call-rv->inputs result-in-registers outputrt) output))) (defmethod translate-simple-instruction ((instruction cc-bmir:fixed-mv-local-call) abi) @@ -1042,6 +825,7 @@ (gen-local-call callee (if (= (length mvargrt) 1) (list mvargi) mvargi) + mvargrt (cc-bmir:rtype output)) output))) @@ -1646,7 +1430,9 @@ (make-instance 'cmp::general-xep-arguments :array (third args) :nargs (second args)) (make-instance 'cmp::fixed-xep-arguments - :arguments (rest args))) + :arguments (rest args) + :vrtypes (make-list (length (rest args)) + :initial-element :object))) :fname closure-vec :rest-alloc (compute-rest-alloc analysis))) ;; Import cells. (llvm-function-info (find-llvm-function-info ir)) From 013faca2838d4e929d4e67d31fe2f0409bab5be4 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Sun, 5 May 2024 15:42:28 -0400 Subject: [PATCH 17/37] Add return-type to mangled wrapper names --- src/scraper/code-generator.lisp | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/scraper/code-generator.lisp b/src/scraper/code-generator.lisp index 4c2a8ecdf0..ef6cedd300 100644 --- a/src/scraper/code-generator.lisp +++ b/src/scraper/code-generator.lisp @@ -264,18 +264,26 @@ ) (format sout "#endif // EXPOSE_FUNCTION_BATCH~a~%" batch-num)))))) -(defun mangle-and-wrap-name (name arg-types) +(defun sanitize (stream argument colonp atsignp &rest params) + (declare (ignore argument colonp atsignp)) + (loop with underscore = nil + for c across (write-to-string argument) + when (alphanumericp c) + do (setf underscore nil) + (princ c stream) + else unless underscore + do (princ #\_ stream) + (setf underscore t))) + +(defun mangle-and-wrap-name (name return-type arg-types) "* Arguments - name :: A string * Description Convert colons to underscores" - (let ((type-part (with-output-to-string (sout) - (loop for type in arg-types - do (loop for c across type - do (if (alphanumericp c) - (princ c sout) - (princ #\_ sout))))))) - (format nil "wrapped_~a_~a" (substitute #\_ #\: name) type-part))) + (format nil "wrapped_~/cscrape:sanitize/_~/cscrape:sanitize/_~{~/cscrape:sanitize/~^_~}" + name + return-type + arg-types)) (defgeneric direct-call-function (c-code cl-code func c-code-info cl-code-info)) @@ -288,7 +296,7 @@ Convert colons to underscores" (if (function-ptr-type function-ptr) (multiple-value-bind (return-type arg-types) (convert-function-ptr-to-c++-types function-ptr) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (function-ptr-namespace function-ptr) @@ -314,7 +322,7 @@ Convert colons to underscores" (defmethod direct-call-function (c-code cl-code (func expose-defun) c-code-info cl-code-info) (multiple-value-bind (return-type arg-types) (parse-types-from-signature (signature% func)) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (namespace% func) @@ -336,7 +344,7 @@ Convert colons to underscores" (defmethod direct-call-function (c-code cl-code (func expose-defun-setf) c-code-info cl-code-info) (multiple-value-bind (return-type arg-types) (parse-types-from-signature (signature% func)) - (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) arg-types)) + (let* ((wrapped-name (mangle-and-wrap-name (function-name% func) return-type arg-types)) (one-func-code (generate-wrapped-function wrapped-name (namespace% func) From 41c8c919de60ac16e7216e3b7be68276fc41e5a2 Mon Sep 17 00:00:00 2001 From: Bike Date: Sun, 5 May 2024 17:00:17 -0400 Subject: [PATCH 18/37] Use LLVM's poison instead of undef in most places poison seems to be the wave of the future (LLVM docs currently say to use it instead of undef whenever possible). It's "more undefined" than undef, so it might help LLVM passes do more optimization. Though I don't know how much it matters in practice. I left in a few undefs I didn't immediately understand the context of, but those can probably be poison too. --- include/clasp/llvmo/llvmoExpose.h | 31 +++++++++++++++- src/analysis/clasp_gc.sif | 47 ++++++++++++++---------- src/analysis/clasp_gc_cando.sif | 33 +++++++++++------ src/lisp/kernel/cleavir/arguments.lisp | 14 +++---- src/lisp/kernel/cleavir/cast.lisp | 6 +-- src/lisp/kernel/cleavir/landing-pad.lisp | 4 +- src/lisp/kernel/cleavir/translate.lisp | 2 +- src/llvmo/llvmoExpose.cc | 13 ++++++- 8 files changed, 103 insertions(+), 47 deletions(-) diff --git a/include/clasp/llvmo/llvmoExpose.h b/include/clasp/llvmo/llvmoExpose.h index c9713c01ea..5f34d16ed8 100644 --- a/include/clasp/llvmo/llvmoExpose.h +++ b/include/clasp/llvmo/llvmoExpose.h @@ -2913,7 +2913,36 @@ template <> struct to_object { static core::T_sp convert(llvm::UndefValue* ptr) { return ((llvmo::UndefValue_O::create(ptr))); } }; }; // namespace translate - ; + +namespace llvmo { +FORWARD(PoisonValue); +class PoisonValue_O : public UndefValue_O { + LISP_EXTERNAL_CLASS(llvmo, LlvmoPkg, llvm::PoisonValue, PoisonValue_O, "PoisonValue", UndefValue_O); + typedef llvm::PoisonValue ExternalType; + typedef llvm::PoisonValue* PointerToExternalType; + +public: + PointerToExternalType wrappedPtr() { return llvm_cast(this->_ptr); } + PointerToExternalType wrappedPtr() const { return llvm_cast(this->_ptr); } + void set_wrapped(PointerToExternalType ptr) { + this->_ptr = ptr; + } + static PoisonValue_sp create(llvm::PoisonValue* ptr); + PoisonValue_O() : Base(){}; + ~PoisonValue_O() {} + +public: + string __repr__() const; +}; // PoisonValue_O +}; // namespace llvmo +/* from_object translators */ +/* to_object translators */ + +namespace translate { +template <> struct to_object { + static core::T_sp convert(llvm::PoisonValue* ptr) { return ((llvmo::PoisonValue_O::create(ptr))); } +}; +}; // namespace translate namespace llvmo { FORWARD(ConstantPointerNull); diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index e5dff00ea2..ed8d823cd6 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -103,25 +103,26 @@ "llvmo::Constant_O" "llvmo::FunctionCallee_O" "llvmo::DIBasicType_O" "llvmo::DIBuilder_O" "core::NativeVector_int_O" "llvmo::APInt_O" "llvmo::APFloat_O" "core::SimpleMDArrayCharacter_O" - "core::SimpleCharacterString_O" "core::Symbol_O" "core::Array_O" - "core::MDArray_byte4_t_O" "llvmo::Argument_O" "core::Iterator_O" - "llvmo::IRBuilderBase_O" "core::Null_O" "core::RequiredArgument" - "core::SingleDispatchMethod_O" "comp::VarInfo_O" "core::CxxObject_O" - "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" - "core::MDArray_byte16_t_O" "llvmo::DIContext_O" "llvmo::JITDylib_O" - "llvmo::Type_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "core::FileScope_O" "core::Float_O" - "core::SimpleMDArray_byte4_t_O" "llvmo::DIDerivedType_O" - "comp::EntryCloseFixup_O" "core::SimpleVector_int64_t_O" - "llvmo::ConstantDataSequential_O" "comp::EntryFixup_O" - "core::MDArray_double_O" "llvmo::StoreInst_O" "llvmo::DebugLoc_O" - "core::WeakPointer_O" "core::DestDynEnv_O" "comp::Annotation_O" - "core::DynEnv_O" "core::BytecodeAstBlock_O" "comp::LexSetFixup_O" - "core::SimpleMDArray_byte8_t_O" "comp::SymbolMacroVarInfo_O" - "core::UnwindProtectDynEnv_O" "comp::LexicalInfo_O" - "llvmo::Instruction_O" "core::FileStream_O" "comp::ExitFixup_O" - "core::Rational_O" "core::CatchDynEnv_O" "core::MDArrayCharacter_O" - "llvmo::LandingPadInst_O" "core::ImmobileObject_O" "core::Function_O" + "core::SimpleCharacterString_O" "llvmo::PoisonValue_O" "core::Symbol_O" + "core::Array_O" "core::MDArray_byte4_t_O" "llvmo::Argument_O" + "core::Iterator_O" "llvmo::IRBuilderBase_O" "core::Null_O" + "core::RequiredArgument" "core::SingleDispatchMethod_O" "comp::VarInfo_O" + "core::CxxObject_O" "llvmo::ReturnInst_O" "llvmo::FunctionType_O" + "clbind::DummyCreator_O" "core::MDArray_byte16_t_O" "llvmo::DIContext_O" + "llvmo::JITDylib_O" "llvmo::Type_O" "core::Pointer_O" + "llvmo::UnreachableInst_O" "core::ComplexVector_int64_t_O" + "core::FileScope_O" "core::Float_O" "core::SimpleMDArray_byte4_t_O" + "llvmo::DIDerivedType_O" "comp::EntryCloseFixup_O" + "core::SimpleVector_int64_t_O" "llvmo::ConstantDataSequential_O" + "comp::EntryFixup_O" "core::MDArray_double_O" "llvmo::StoreInst_O" + "llvmo::DebugLoc_O" "core::WeakPointer_O" "core::DestDynEnv_O" + "comp::Annotation_O" "core::DynEnv_O" "core::BytecodeAstBlock_O" + "comp::LexSetFixup_O" "core::SimpleMDArray_byte8_t_O" + "comp::SymbolMacroVarInfo_O" "core::UnwindProtectDynEnv_O" + "comp::LexicalInfo_O" "llvmo::Instruction_O" "core::FileStream_O" + "comp::ExitFixup_O" "core::Rational_O" "core::CatchDynEnv_O" + "core::MDArrayCharacter_O" "llvmo::LandingPadInst_O" + "core::ImmobileObject_O" "core::Function_O" "core::SimpleMDArray_int2_t_O" "core::HashTableEql_O" "comp::ConstantInfo_O" "mp::ConditionVariable_O" "core::Real_O" "core::Lisp" "core::MDArray_byte8_t_O" "core::BytecodeAstThe_O" @@ -4362,6 +4363,14 @@ :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_Class")} {fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_ptr")} +{class-kind :stamp-name "STAMPWTAG_llvmo__PoisonValue_O" :stamp-key "llvmo::PoisonValue_O" + :parent-class "llvmo::UndefValue_O" :lisp-class-base "llvmo::UndefValue_O" + :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_Class")} +{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_ptr")} {class-kind :stamp-name "STAMPWTAG_llvmo__ConstantArray_O" :stamp-key "llvmo::ConstantArray_O" :parent-class "llvmo::Constant_O" :lisp-class-base "llvmo::Constant_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index 7e51558fce..cc966ffc63 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -176,18 +176,19 @@ "chem::ResidueOut" "core::NativeVector_int_O" "llvmo::DIBasicType_O" "llvmo::DIBuilder_O" "llvmo::APInt_O" "llvmo::APFloat_O" "core::SimpleMDArrayCharacter_O" "core::SimpleCharacterString_O" - "core::Symbol_O" "chem::AtomOrBondMatchNode_O" "core::Array_O" - "core::MDArray_byte4_t_O" "llvmo::Argument_O" "chem::FFItorDb_O" - "llvmo::IRBuilderBase_O" "units::Unit_O" "core::Null_O" - "chem::RingFinder_O" "chem::IterateBonds_O" "core::RequiredArgument" - "core::SingleDispatchMethod_O" "chem::CDFragment_O" "comp::VarInfo_O" - "core::CxxObject_O" "llvmo::ReturnInst_O" "llvmo::FunctionType_O" - "clbind::DummyCreator_O" "chem::EnergyDihedralRestraint" - "core::MDArray_byte16_t_O" "llvmo::DIContext_O" - "chem::FFNonbondCrossTermTable_O" "llvmo::JITDylib_O" "llvmo::Type_O" - "chem::Command_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "chem::FFParameterBaseDb_O" - "core::FileScope_O" "core::SimpleMDArray_byte4_t_O" "core::Float_O" + "llvmo::PoisonValue_O" "core::Symbol_O" "chem::AtomOrBondMatchNode_O" + "core::Array_O" "core::MDArray_byte4_t_O" "llvmo::Argument_O" + "chem::FFItorDb_O" "llvmo::IRBuilderBase_O" "units::Unit_O" + "core::Null_O" "chem::RingFinder_O" "chem::IterateBonds_O" + "core::RequiredArgument" "core::SingleDispatchMethod_O" + "chem::CDFragment_O" "comp::VarInfo_O" "core::CxxObject_O" + "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" + "chem::EnergyDihedralRestraint" "core::MDArray_byte16_t_O" + "llvmo::DIContext_O" "chem::FFNonbondCrossTermTable_O" + "llvmo::JITDylib_O" "llvmo::Type_O" "chem::Command_O" "core::Pointer_O" + "llvmo::UnreachableInst_O" "core::ComplexVector_int64_t_O" + "chem::FFParameterBaseDb_O" "core::FileScope_O" + "core::SimpleMDArray_byte4_t_O" "core::Float_O" "chem::EnergySketchStretch" "chem::ResidueTest_O" "chem::RestraintDistance_O" "llvmo::DIDerivedType_O" "chem::SmartsRoot_O" "chem::TwisterDriver_O" "comp::EntryCloseFixup_O" @@ -9195,6 +9196,14 @@ :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_Class")} {fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "llvmo::UndefValue_O" :layout-offset-field-names ("_ptr")} +{class-kind :stamp-name "STAMPWTAG_llvmo__PoisonValue_O" :stamp-key "llvmo::PoisonValue_O" + :parent-class "llvmo::UndefValue_O" :lisp-class-base "llvmo::UndefValue_O" + :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_Class")} +{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "llvmo::PoisonValue_O" :layout-offset-field-names ("_ptr")} {class-kind :stamp-name "STAMPWTAG_llvmo__ConstantArray_O" :stamp-key "llvmo::ConstantArray_O" :parent-class "llvmo::Constant_O" :lisp-class-base "llvmo::Constant_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} diff --git a/src/lisp/kernel/cleavir/arguments.lisp b/src/lisp/kernel/cleavir/arguments.lisp index 162d85bead..788a64b4c0 100644 --- a/src/lisp/kernel/cleavir/arguments.lisp +++ b/src/lisp/kernel/cleavir/arguments.lisp @@ -153,7 +153,7 @@ switch (nargs) { for val = (if enough (clasp-cleavir::cast-one src-vrtype var-rtype (nth-arg xepargs j)) - (llvm-sys:undef-value-get var-ltype)) + (llvm-sys:poison-value-get var-ltype)) do (irc-phi-add-incoming suppliedp-phi sp new) (irc-phi-add-incoming var-phi val new)) (irc-br assn))) @@ -194,7 +194,7 @@ switch (nargs) { for suppliedp-rtype = (first (clasp-cleavir-bmir:rtype suppliedp)) for arg = (pop args) for val = (if (null arg) - (llvm-sys:undef-value-get + (llvm-sys:poison-value-get (clasp-cleavir::vrtype->llvm var-rtype)) (clasp-cleavir::cast-one (pop src-vrtypes) var-rtype arg)) for sp = (ecase suppliedp-rtype @@ -209,7 +209,7 @@ switch (nargs) { (list (cond ((eq rest-alloc 'ignore) ;; &rest variable is ignored- allocate nothing - (irc-undef-value-get (clasp-cleavir::vrtype->llvm rtype))) + (llvm-sys:poison-value-get (clasp-cleavir::vrtype->llvm rtype))) ((eq rest-alloc 'dynamic-extent) ;; Do the dynamic extent thing- alloca, then an intrinsic to initialize it. (let ((rrest (alloca-dx-list :length nremaining :label "rrest"))) @@ -242,7 +242,7 @@ Having to write with phi nodes unfortunately makes things rather more confusing. if ((remaining_nargs % 2) == 1) cc_oddKeywordException([*fname*]); -tstar bad_keyword = undef; +tstar bad_keyword = poison; bool seen_bad_keyword = false; tstar allow_other_keys = [nil], allow_other_keys_p = [nil]; for (; remaining_nargs != 0; remaining_nargs -= 2) { @@ -284,7 +284,7 @@ if (seen_bad_keyword) (let ((aok-parameter-p nil) allow-other-keys (nkeys (car keyargs)) - (undef (irc-undef-value-get %t*%)) + (poison (llvm-sys:poison-value-get %t*%)) (start (irc-basic-block-create "parse-key-arguments")) (matching (irc-basic-block-create "match-keywords")) (after (irc-basic-block-create "after-kw-loop")) @@ -323,7 +323,7 @@ if (seen_bad_keyword) (bad-keyword (irc-phi %t*% 2 "bad-keyword"))) (irc-phi-add-incoming nargs-remaining nremaining start) (irc-phi-add-incoming sbkw (jit-constant-false) start) - (irc-phi-add-incoming bad-keyword undef start) + (irc-phi-add-incoming bad-keyword poison start) (loop for (key) on (cdr keyargs) by #'cddddr for var-phi = (irc-phi %t*% 2 (format nil "~a-top" key)) for suppliedp-phi = (irc-phi %t*% 2 (format nil "~s-suppliedp-top" key)) @@ -334,7 +334,7 @@ if (seen_bad_keyword) (cond ((and (not lambda-list-aokp) (eq key :allow-other-keys)) (irc-phi-add-incoming var-phi false start) (setf allow-other-keys var-phi)) - (t (irc-phi-add-incoming var-phi undef start))) + (t (irc-phi-add-incoming var-phi poison start))) (irc-phi-add-incoming suppliedp-phi false start)) (setf top-param-phis (nreverse top-param-phis) top-suppliedp-phis (nreverse top-suppliedp-phis)) diff --git a/src/lisp/kernel/cleavir/cast.lisp b/src/lisp/kernel/cleavir/cast.lisp index 802d4287ee..9ec991a1f5 100644 --- a/src/lisp/kernel/cleavir/cast.lisp +++ b/src/lisp/kernel/cleavir/cast.lisp @@ -62,11 +62,11 @@ ;; a value, but control will never actually reach it. ;; Ideally the compiler would not bother compiling ;; such unreachable code, but sometimes it's stupid. - ((:fixnum) (llvm-sys:undef-value-get cmp:%fixnum%)) + ((:fixnum) (llvm-sys:poison-value-get cmp:%fixnum%)) ((:single-float) - (llvm-sys:undef-value-get cmp:%float%)) + (llvm-sys:poison-value-get cmp:%float%)) ((:double-float) - (llvm-sys:undef-value-get cmp:%double%)))) + (llvm-sys:poison-value-get cmp:%double%)))) (t (cast-one (first inputrt) (first outputrt) (first inputv))))) diff --git a/src/lisp/kernel/cleavir/landing-pad.lisp b/src/lisp/kernel/cleavir/landing-pad.lisp index fbe4b38de8..04b5092b26 100644 --- a/src/lisp/kernel/cleavir/landing-pad.lisp +++ b/src/lisp/kernel/cleavir/landing-pad.lisp @@ -71,8 +71,8 @@ (_ (cmp:irc-set-insert-point-basic-block ehresume ehbuilder)) (exn7 (llvm-sys:create-load-type-value-twine ehbuilder cmp:%exn% exn.slot "exn7")) (sel (llvm-sys:create-load-type-value-twine ehbuilder cmp:%ehselector% ehselector.slot "sel")) - (undef (llvm-sys:undef-value-get cmp:%exception-struct% )) - (lpad.val (llvm-sys:create-insert-value ehbuilder undef exn7 '(0) "lpad.val")) + (poison (llvm-sys:poison-value-get cmp:%exception-struct% )) + (lpad.val (llvm-sys:create-insert-value ehbuilder poison exn7 '(0) "lpad.val")) (lpad.val8 (llvm-sys:create-insert-value ehbuilder lpad.val sel '(1) "lpad.val8")) (_1 (llvm-sys:create-resume ehbuilder lpad.val8))) (declare (ignore _ _1)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 23f858f5b0..7abb043a30 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -173,7 +173,7 @@ ((null (rest rt)) (cmp:irc-ret inv)) (t ; fixed values return: construct an aggregate and return it. (let* ((stype (return-rtype->llvm rt)) - (s (llvm-sys:undef-value-get stype))) + (s (llvm-sys:poison-value-get stype))) (loop for i from 0 for v in inv do (setf s (cmp:irc-insert-value s v (list i)))) diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index daa4fccc33..72364adbe5 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -2168,13 +2168,22 @@ UndefValue_sp UndefValue_O::create(llvm::UndefValue* ptr) { return core::RP_Crea CL_LISPIFY_NAME(UNDEF_VALUE-GET); CL_EXTERN_DEFUN((llvm::UndefValue * (*)(llvm::Type * type)) & llvm::UndefValue::get); -; - string UndefValue_O::__repr__() const { stringstream ss; ss << "#<" << this->_instanceClass()->_classNameAsString() << ">"; return ss.str(); } + +PoisonValue_sp PoisonValue_O::create(llvm::PoisonValue* ptr) { return core::RP_Create_wrapped(ptr); }; + +CL_LISPIFY_NAME(POISON_VALUE-GET); +CL_EXTERN_DEFUN((llvm::PoisonValue * (*)(llvm::Type * type)) & llvm::PoisonValue::get); + +string PoisonValue_O::__repr__() const { + stringstream ss; + ss << "#<" << this->_instanceClass()->_classNameAsString() << ">"; + return ss.str(); +} }; // namespace llvmo namespace llvmo { From 2f9ed4f7d08291dc23d78df5f64e66ecb7373cfa Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 8 May 2024 15:47:41 -0400 Subject: [PATCH 19/37] Make backtraces a little better at optimized code When LLVM optimization is on, it will often inline functions, and in particular will inline core functions into their XEPs. The DWARF information will reflect this inlining, so the address range for a given return address may be of the inline function body rather than that of the actual entry point. And that would break backtraces. This fix ignores the address ranges of the return address, instead just checking the ranges of the object file's literal functions. That works, but ideally we would use the DWARF information to give us information about inlined functions. Also, with optimization on a few tests on backtraces fail, so that also needs fixing. --- include/clasp/core/backtrace.h | 4 +- src/core/backtrace.cc | 168 ++++++++++++--------------------- 2 files changed, 62 insertions(+), 110 deletions(-) diff --git a/include/clasp/core/backtrace.h b/include/clasp/core/backtrace.h index b82c4dedf0..7006fdc6fa 100644 --- a/include/clasp/core/backtrace.h +++ b/include/clasp/core/backtrace.h @@ -82,7 +82,7 @@ FORWARD(SectionedAddress); namespace core { -T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, llvmo::SectionedAddress_sp sa, - void*& codeStart, void*& functionStartAddress, bool& XEPp, int& arityCode); +T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, void* absolute_ip, + void*& functionStartAddress, bool& XEPp, int& arityCode); } // namespace core diff --git a/src/core/backtrace.cc b/src/core/backtrace.cc index d64c822c49..01159f1dd9 100644 --- a/src/core/backtrace.cc +++ b/src/core/backtrace.cc @@ -161,102 +161,74 @@ static T_sp getSourcePosInfoForAddress(llvmo::DWARFContext_sp dcontext, llvmo::S return core__makeSourcePosInfo(source_path, true, 0, false, info.Line, true, info.Column, true); } -T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, llvmo::SectionedAddress_sp sa, - void*& codeStart, void*& functionStartAddress, bool& XEPp, int& arityCode) { +// Given the start of a function (HERE), and an address and that address's +// object file and DWARF context, determine if the address is within that +// function. Sorta similar to debugger.cc's lookup_address. +static bool function_starting_here_contains_addr_p(llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, uintptr_t here, uintptr_t addr) { + void* here_ip = (void*)here; + // See if we are in the right object file. An object file's literals may + // include functions from other object files (e.g. due to weird #. stuff) + // and we don't want to check those. + if ((here < ofi->codeStart()) || (here > ofi->codeEnd())) + return false; + uintptr_t reladdr = addr - ofi->codeStart(); + llvmo::SectionedAddress_sp sa = llvmo::object_file_sectioned_address(here_ip, ofi, false); + auto eranges = llvmo::getAddressRangesForAddressInner(dcontext, sa); + if (!eranges) return false; // no debug info + for (auto range : eranges.get()) { + if ((range.LowPC <= reladdr) && (reladdr <= range.HighPC)) + return true; + } + return false; // not in any of the ranges +} + +T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_sp dcontext, void* absolute_ip, + void*& functionStartAddress, bool& XEPp, int& arityCode) { MaybeTrace trace(__FUNCTION__); - functionStartAddress = NULL; - D(printf("%s:%d:%s frameIndex = %lu\n", __FILE__, __LINE__, __FUNCTION__, frameIndex);); + functionStartAddress = NULL; XEPp = false; arityCode = 0; // // If the object file contains the interpreter_trampoline - then we are in the interpreter // if (ofi->codeStart() <= (uintptr_t)bytecode_trampoline && (uintptr_t)bytecode_trampoline < ofi->codeEnd()) { functionStartAddress = (void*)bytecode_trampoline; - D(printf("%s:%d:%s bytecode trampoline functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, functionStartAddress);); return nil(); } - auto expected_ranges = llvmo::getAddressRangesForAddressInner(dcontext, sa); - if (expected_ranges) { - auto ranges = expected_ranges.get(); - if (ranges.size() == 0) { - D(printf("%s:%d:%s No ranges were found for %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(sa).c_str());); - } else { - if (ranges.size() > 1) { - printf("%s:%d:%s There is more than one range - there are %lu\n", __FILE__, __LINE__, __FUNCTION__, ranges.size()); - } else { - llvmo::ObjectFile_sp code = ofi; - codeStart = (void*)code->codeStart(); - uintptr_t absolute_LowPC = ranges.begin()->LowPC + (uintptr_t)codeStart; - functionStartAddress = (void*)(absolute_LowPC); - D(printf("%s:%d:%s Calculated functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, functionStartAddress);); - T_O** rliterals = code->TOLiteralsStart(); - size_t nliterals = code->TOLiteralsSize(); - D(printf("%s%s:%d:%s sectioned address %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(sa).c_str());); - D(printf("%s%s:%d:%s codeStart = %p - %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, (void*)codeStart, - (void*)codeEnd);); - D(printf("%s%s:%d:%s objectFile = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(ofi).c_str());); - D(for (auto range - : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - printf("%s%s:%d:%s found range %p - %p Absolute %p - %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - (void*)range.LowPC, (void*)range.HighPC, (void*)absolute_LowPC, (void*)absolute_HighPC); - } printf("%s%s:%d:%s rliterals = %p nliterals = %lu\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, rliterals, - nliterals);); - for (size_t i = 0; i < nliterals; ++i) { - T_sp literal((gc::Tagged)(rliterals[i])); - if (gc::IsA(literal)) { - CoreFun_sp ep = gc::As_unsafe(literal); - uintptr_t absolute_entry = (uintptr_t)(ep->_Entry); - D(printf("%s%s:%d:%s CoreFun_sp %s absolute_entry = %p FunctionDescription name %s\n", trace.spaces().c_str(), - __FILE__, __LINE__, __FUNCTION__, _rep_(ep).c_str(), (void*)absolute_entry, - _rep_(ep->functionDescription()).c_str());); - for (auto range : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - if ((absolute_LowPC <= absolute_entry) && (absolute_entry < absolute_HighPC)) { - D(printf("%s%s:%d:%s Matched absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, (void*)absolute_LowPC, (void*)absolute_HighPC);); - XEPp = false; - // This will be identical to the entry point address in CoreFun_sp ep - return ep; - } else { - D(printf("%s%s:%d:%s DID NOT match absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), __FILE__, - __LINE__, __FUNCTION__, (void*)absolute_LowPC, (void*)absolute_HighPC);); - } - } - } else if (gc::IsA(literal)) { - SimpleFun_sp ep = gc::As_unsafe(literal); - D(printf("%s%s:%d:%s SimpleCoreFun_sp %s FunctionDescription name %s\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, _rep_(ep).c_str(), _rep_(ep->functionDescription()).c_str());); - for (size_t j = 0; j < NUMBER_OF_ENTRY_POINTS; ++j) { - uintptr_t absolute_entry = (uintptr_t)(ep->_EntryPoints[j]); - for (auto range : ranges) { - uintptr_t absolute_LowPC = range.LowPC + (uintptr_t)codeStart; - uintptr_t absolute_HighPC = range.HighPC + (uintptr_t)codeStart; - if ((absolute_LowPC <= absolute_entry) && (absolute_entry < absolute_HighPC)) { - D(printf("%s%s:%d:%s Matched arityCode: %lu absolute_LowPC/absolute_HighPC %p/%p\n", trace.spaces().c_str(), - __FILE__, __LINE__, __FUNCTION__, j, (void*)absolute_LowPC, (void*)absolute_HighPC);); - XEPp = true; - // This will be identical to ONE of the the entry point address in SimpleFun_sp ep - // arityCode is the index into the SimpleFun_sp vector corresponding to functionStartAddress - arityCode = j; - return ep; - } else { - // D(printf("%s%s:%d:%s absolute_entry -> %p DID NOT match absolute_LowPC/absolute_HighPC %p/%p\n", - // trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, (void*)absolute_entry, (void*)absolute_LowPC, - // (void*)absolute_HighPC );); - } - } - } - } + // Otherwise, we are hopefully in the object file somewhere. + // We go through all the literals in the object file looking for compiled + // functions, and get their ranges from the DWARF (this is similar to the + // lookup_address function in debugger.cc). Then if we're in one of those + // ranges, we have our entry point. + // We used to get the DWARF address ranges for the return address, but this + // is problematic in the presence of inlining: We will get the DWARF DIE for + // the inlined function, which is narrower than the actual entry point. + // Although, FIXME, we should report inlining properly. + uintptr_t retaddr = (uintptr_t)absolute_ip; + uintptr_t codeStart = ofi->codeStart(); + T_O** rliterals = ofi->TOLiteralsStart(); + size_t nliterals = ofi->TOLiteralsSize(); + for (size_t i = 0; i < nliterals; ++i) { + T_sp literal((gc::Tagged)(rliterals[i])); + if (gc::IsA(literal)) { + CoreFun_sp ep = gc::As_unsafe(literal); + uintptr_t entry = (uintptr_t)ep->_Entry; + if (function_starting_here_contains_addr_p(ofi, dcontext, entry, retaddr)) { + functionStartAddress = (void*)entry; + XEPp = false; + return ep; + } + } else if (gc::IsA(literal)) { + SimpleFun_sp ep = gc::As_unsafe(literal); + for (size_t j = 0; j < NUMBER_OF_ENTRY_POINTS; ++j) { + uintptr_t entry = (uintptr_t)(ep->_EntryPoints[j]); + if (function_starting_here_contains_addr_p(ofi, dcontext, entry, retaddr)) { + functionStartAddress = (void*)entry; + XEPp = true; + arityCode = j; } - // no hits - return nil(); } } } - D(printf("%s:%d:%s No eranges\n", __FILE__, __LINE__, __FUNCTION__);); + // no hits within the literals. return nil(); } @@ -380,7 +352,7 @@ bool sanity_check_args(void* frameptr, int32_t offset32, int64_t patch_point_id) } __attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, const char* string, bool XEPp, int arityCode, - void* code_start, void* functionStartAddress, llvmo::ObjectFile_sp ofi, + void* functionStartAddress, llvmo::ObjectFile_sp ofi, T_sp& functionDescriptionOrNil, void* frameptr, T_sp& closure, T_sp& args) { MaybeTrace trace(__FUNCTION__); if (!functionStartAddress) { @@ -398,9 +370,6 @@ __attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, cons ; if (gc::IsA(functionDescriptionOrNil)) name = gc::As_unsafe(functionDescriptionOrNil); - D(printf("%s%s:%d:%s functionStartAddress FunctionDescription %s code_start = %p functionStartAddress = %p\n", - trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(name).c_str(), (void*)code_start, - functionStartAddress);); auto thunk = [&](size_t _, const smStkSizeRecord& function, int32_t offsetOrSmallConstant, int64_t patchPointId) { if (function.FunctionAddress == (uintptr_t)functionStartAddress) { MaybeTrace tracel("functionStartAddress_thunk"); @@ -424,44 +393,28 @@ static DebuggerFrame_sp make_lisp_frame(size_t frameIndex, void* absolute_ip, co MaybeTrace trace(__FUNCTION__); llvmo::SectionedAddress_sp sa = object_file_sectioned_address(absolute_ip, ofi, false); llvmo::DWARFContext_sp dcontext = llvmo::DWARFContext_O::createDWARFContext(ofi); - D(printf("%s%s:%d:%s sa= %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(sa).c_str());); T_sp spi = getSourcePosInfoForAddress(dcontext, sa); - D(printf("%s%s:%d:%s spi= %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(spi).c_str());); bool XEPp = false; int arityCode; - void* codeStart; void* functionStartAddress; - T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, sa, codeStart, functionStartAddress, XEPp, arityCode); - D(printf("%s:%d:%s dwarf_ep returned ep = %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(ep).c_str());); - D(printf("%s:%d:%s dwarf_ep returned functionStartAddress = %p\n", __FILE__, __LINE__, __FUNCTION__, - (void*)functionStartAddress);); + T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, absolute_ip, functionStartAddress, XEPp, arityCode); T_sp functionDescriptionOrNil = nil(); if (gc::IsA(ep)) functionDescriptionOrNil = gc::As_unsafe(ep)->functionDescription(); else if (gc::IsA(ep)) functionDescriptionOrNil = gc::As_unsafe(ep)->functionDescription(); - D(printf("%s:%d:%s functionDescriptionOrNil = %s\n", __FILE__, __LINE__, __FUNCTION__, _rep_(functionDescriptionOrNil).c_str());); T_sp closure = nil(), args = nil(); - bool args_available = args_for_function(frameIndex, absolute_ip, string, XEPp, arityCode, codeStart, functionStartAddress, ofi, + bool args_available = args_for_function(frameIndex, absolute_ip, string, XEPp, arityCode, functionStartAddress, ofi, functionDescriptionOrNil, fbp, closure, args); T_sp fname = nil(); if (gc::IsA(functionDescriptionOrNil)) { fname = gc::As_unsafe(functionDescriptionOrNil)->functionName(); - D(printf("%s%s:%d:%s Using functionDescriptionOrNil %s to get name\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(fname).c_str());); } else if (args_available && gc::IsA(closure)) { fname = gc::As_unsafe(closure)->functionName(); - D(printf("%s%s:%d:%s Using closure %s to get name\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, - _rep_(fname).c_str());); } - D(printf("%s%s:%d:%s fname = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(fname).c_str());); if (fname.nilp() && string) { - D(printf( - "%s:%d:%s So sad - the function-description name is NIL and the function-description.nilp()->%d trying to use string\n", - __FILE__, __LINE__, __FUNCTION__, functionDescriptionOrNil.nilp());); fname = SimpleBaseString_O::make(std::string(string)); } - D(printf("%s%s:%d:%s string = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, string);); return DebuggerFrame_O::make(fname, Cons_O::create(sa, ofi), spi, functionDescriptionOrNil, closure, args, args_available, nil(), INTERN_(kw, lisp), XEPp); } @@ -600,11 +553,10 @@ static bool sanity_check_frame(size_t frameIndex, void* ip, void* fbp) { llvmo::ObjectFile_sp ofi = gc::As_unsafe(of); llvmo::SectionedAddress_sp sa = object_file_sectioned_address(ip, ofi, false); llvmo::DWARFContext_sp dcontext = llvmo::DWARFContext_O::createDWARFContext(ofi); - void* codeStart; void* functionStartAddress; bool XEPp = false; int arityCode; - T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, sa, codeStart, functionStartAddress, XEPp, arityCode); + T_sp ep = dwarf_ep(frameIndex, ofi, dcontext, ip, functionStartAddress, XEPp, arityCode); uintptr_t stackmap_start = (uintptr_t)(ofi->_StackmapStart); uintptr_t stackmap_end = stackmap_start + ofi->_StackmapSize; if (gc::IsA(ep)) { From d28a1e4473ebdb7f639e1a33dda870039c16f4d8 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 8 May 2024 15:59:21 -0400 Subject: [PATCH 20/37] Delete unused code No idea what this is, but nothing actually uses it --- include/clasp/llvmo/claspLinkPass.h | 32 ---------- src/llvmo/claspLinkPass.cc | 94 ----------------------------- src/llvmo/llvmoPackage.cc | 1 - 3 files changed, 127 deletions(-) delete mode 100644 include/clasp/llvmo/claspLinkPass.h delete mode 100644 src/llvmo/claspLinkPass.cc diff --git a/include/clasp/llvmo/claspLinkPass.h b/include/clasp/llvmo/claspLinkPass.h deleted file mode 100644 index c9604c8746..0000000000 --- a/include/clasp/llvmo/claspLinkPass.h +++ /dev/null @@ -1,32 +0,0 @@ -#pragma once - -/* - File: claspLinkPass.h -*/ - -/* -Copyright (c) 2014, Christian E. Schafmeister - -CLASP is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public -License as published by the Free Software Foundation; either -version 2 of the License, or (at your option) any later version. - -See directory 'clasp/licenses' for full details. - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. -*/ -/* -^- */ -namespace llvmo { - -void initialize_claspLinkPass(); -}; diff --git a/src/llvmo/claspLinkPass.cc b/src/llvmo/claspLinkPass.cc deleted file mode 100644 index 2d140d1898..0000000000 --- a/src/llvmo/claspLinkPass.cc +++ /dev/null @@ -1,94 +0,0 @@ -/* - File: claspLinkPass.cc -*/ - -/* -Copyright (c) 2014, Christian E. Schafmeister - -CLASP is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public -License as published by the Free Software Foundation; either -version 2 of the License, or (at your option) any later version. - -See directory 'clasp/licenses' for full details. - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. -*/ -/* -^- */ -#include -#include -#include -#include - -#include -#include -#include - -using namespace llvm; - -namespace { -struct ClaspLinkPass : public ModulePass { - static char ID; - ClaspLinkPass() : ModulePass(ID) {} - - virtual bool runOnModule(Module& M) { - errs() << "ClaspLinkPass " << __FILE__ << ":" << __LINE__ << '\n'; - GlobalVariable* funcs = M.getNamedGlobal(GLOBAL_BOOT_FUNCTIONS_NAME); - if (funcs == NULL) { - errs() << "Could not find global variable " << GLOBAL_BOOT_FUNCTIONS_NAME << '\n'; - return false; - } - llvm::PointerType* t = funcs->getType(); -#if 0 - errs() << "Dumping t\n"; - t->dump(); - errs() << '\n'; - llvm::Type *et = t->getElementType(); - errs() << "Dumping et\n"; - et->dump(); - errs() << '\n'; - int num = et->getArrayNumElements(); - errs() << "Number of elements: " << num << '\n'; - funcs->dump(); -#endif - llvm::ConstantInt* ci = llvm::ConstantInt::get(M.getContext(), llvm::APInt(/*nbits*/ 32, num, true)); -#if 0 -#pragma clang diagnostic push -#pragma GCC diagnostic ignored "-Wunused-variable" - llvm::GlobalVariable *gv = new llvm::GlobalVariable(M, llvm::IntegerType::get(M.getContext(), 32), true, llvm::GlobalValue::InternalLinkage, ci, GLOBAL_BOOT_FUNCTIONS_SIZE_NAME); -#pragma clang diagnostic pop -#endif - return true; // Change this to true once we modify the module - } -}; -} // namespace - -namespace llvmo { - -#define ARGS_af_addGlobalBootFunctionsSizePass "(pass-manager)" -#define DECL_af_addGlobalBootFunctionsSizePass "" -#define DOCS_af_addGlobalBootFunctionsSizePass "addGlobalBootFunctionsSizePass" -DOCGROUP(clasp); -CL_DEFUN void llvm_sys__addGlobalBootFunctionsSizePass(llvmo::PassManager_sp passManager) { - ModulePass* claspLinkPass = new ClaspLinkPass(); - passManager->wrappedPtr()->add(claspLinkPass); -} - -void initialize_claspLinkPass() { - // core::af_def(LlvmoPkg, "addGlobalBootFunctionsSizePass", &af_addGlobalBootFunctionsSizePass); -} -}; // namespace llvmo - -#if 0 -char ClaspLinkPass::ID = 0; -static RegisterPass X(CLASP_LINK_PASS_NAME, "ClaspLinkPass", false, false); -#endif diff --git a/src/llvmo/llvmoPackage.cc b/src/llvmo/llvmoPackage.cc index b9ae5ae731..f2e1316323 100644 --- a/src/llvmo/llvmoPackage.cc +++ b/src/llvmo/llvmoPackage.cc @@ -54,7 +54,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include From 8ef8e97481b3d86106669a4261b79e801abcc2bf Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 8 May 2024 22:36:42 -0400 Subject: [PATCH 21/37] Move LLVM optimization outside of with-module macro Doing it in a macro is just kind of error prone. COMPILE was not doing optimization because the macro didn't have an optimizer listed. And what kind of non-LLVM optimizer function would we even use to optimize an LLVM module? --- src/lisp/kernel/cleavir/translate.lisp | 6 ++-- .../kernel/cmp/compile-file-parallel.lisp | 33 +++++++------------ src/lisp/kernel/cmp/compile-file.lisp | 19 +++-------- src/lisp/kernel/cmp/compile.lisp | 13 ++------ src/lisp/kernel/cmp/disassemble.lisp | 4 +-- src/lisp/kernel/lsp/fli.lisp | 2 +- 6 files changed, 27 insertions(+), 50 deletions(-) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 7abb043a30..0910814cd5 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1866,8 +1866,10 @@ COMPILE-FILE will use the default *clasp-env*." (cmp::with-module (:module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) (with-debuginfo (module :file pathname) - (literal:with-rtv - (translate bir :linkage linkage :abi abi))) + (multiple-value-prog1 + (literal:with-rtv + (translate bir :linkage linkage :abi abi)) + (llvm-sys:optimize-module module cmp:*optimization-level*))) (declare (ignore constants-table)) (jit-add-module-return-function cmp:*the-module* startup-shutdown-id ordered-raw-constants-list))))) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index 42f861833d..ebdfd00d51 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -131,10 +131,9 @@ ;;; (defun compile-from-module (job - &key optimize - optimize-level + &key optimize-level intermediate-output-type) - (declare (ignore optimize optimize-level)) + (declare (ignore optimize-level)) (let ((module (ast-job-module job))) (ecase intermediate-output-type (:in-memory-object @@ -149,12 +148,10 @@ (gctools:thread-local-cleanup)) (values)) -(defun ast-job-to-module (job &key optimize optimize-level) +(defun ast-job-to-module (job &key (optimize-level *optimization-level*)) (let ((module (llvm-create-module (format nil "module~a" (ast-job-form-index job)))) (core:*current-source-pos-info* (ast-job-source-pos-info job))) - (with-module (:module module - :optimize (when optimize #'llvm-sys:optimize-module) - :optimize-level optimize-level) + (with-module (:module module) (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) (clasp-cleavir::with-debuginfo (module :file (namestring cmp::*compile-file-source-debug-pathname*)) (with-literal-table (:id (ast-job-form-index job)) @@ -178,18 +175,16 @@ (cmp-log-dump-module module) (irc-verify-module-safe module) (quick-module-dump module (format nil "preoptimize~a" (ast-job-form-index job))) - ;; ALWAYS link the builtins in, inline them and then remove them. - #+(or)(link-inline-remove-builtins module) - module))) + module) + (llvm-sys:optimize-module module optimize-level) + module)) (defun compile-from-ast (job &key - optimize - optimize-level + (optimize-level *optimization-level*) intermediate-output-type) (setf (ast-job-module job) - (ast-job-to-module job :optimize optimize - :optimize-level optimize-level)) - (compile-from-module job :optimize optimize :optimize-level optimize-level + (ast-job-to-module job :optimize-level optimize-level)) + (compile-from-module job :optimize-level optimize-level :intermediate-output-type intermediate-output-type)) (defun read-one-ast (source-sin environment eof-value) @@ -240,7 +235,6 @@ environment &key (compile-from-module nil) ; If nil - then compile from the ast in threads - optimize optimize-level output-path (intermediate-output-type :in-memory-object) ; or :bitcode @@ -272,7 +266,7 @@ multithreaded performance that we should explore." #+(or cclasp eclasp)(eclector.reader:*client* cmp:*cst-client*) ast-jobs (_ (cfp-log "Starting the pool of threads~%")) - (job-args `(:optimize ,optimize :optimize-level ,optimize-level + (job-args `(:optimize-level ,optimize-level :intermediate-output-type ,intermediate-output-type)) (pool (make-thread-pool (if compile-from-module 'compile-from-module @@ -301,14 +295,13 @@ multithreaded performance that we should explore." :form-index form-index :form-counter form-counter))) (when compile-from-module - (let ((module (ast-job-to-module ast-job :optimize optimize :optimize-level optimize-level))) + (let ((module (ast-job-to-module ast-job :optimize-level optimize-level))) (setf (ast-job-module ast-job) module))) (unless ast-only (push ast-job ast-jobs) (thread-pool-enqueue pool ast-job)) #+(or) (compile-from-ast ast-job - :optimize optimize :optimize-level optimize-level :intermediate-output-type intermediate-output-type)))) ;; Send :quit messages to all threads. @@ -342,7 +335,6 @@ multithreaded performance that we should explore." - environment :: Arbitrary, passed only to hook Compile a lisp source file into an LLVM module." (cclasp-loop2 input-stream environment - :optimize optimize :optimize-level optimize-level :output-path output-path :intermediate-output-type (ecase output-type @@ -402,7 +394,6 @@ Compile a lisp source file into an LLVM module." :output-type output-type :output-path output-path :environment environment - :optimize optimize :optimize-level optimize-level :ast-only ast-only))) (cond (dry-run (format t "Doing nothing further~%") nil) diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index 54b267cbfb..acc353c90f 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -166,7 +166,6 @@ &key environment image-startup-position - (optimize t) (optimize-level *optimization-level*)) "* Arguments - source-sin :: An input stream to read forms from. @@ -175,11 +174,8 @@ Compile a Lisp source stream and return a corresponding LLVM module." (let* ((name (namestring *compile-file-pathname*)) (module (llvm-create-module name)) run-all-name) - (unless module (error "module is NIL")) (cmp-log "About to with-module%N") - (with-module (:module module - :optimize (when optimize #'llvm-sys:optimize-module) - :optimize-level optimize-level) + (with-module (:module module) ;; (1) Generate the code (cmp-log "About to with-make-new-run-all%N") (with-make-new-run-all (run-all-function name) @@ -196,9 +192,7 @@ Compile a Lisp source stream and return a corresponding LLVM module." (make-boot-function-global-variable module run-all-name :position image-startup-position :register-library t)) - ;; Now at the end of with-module another round of optimization is done - ;; but the RUN-ALL is now referenced by the CTOR and so it won't be optimized away - ;; ---- MOVE OPTIMIZATION in with-module to HERE ---- + (llvm-sys:optimize-module module optimize-level) (quick-module-dump module "postoptimize") module)) @@ -241,15 +235,14 @@ Compile a Lisp source stream and return a corresponding LLVM module." ((:source-debug-offset *compile-file-source-debug-offset*) 0) - ;; these ought to be removed, or at least made + ;; this ought to be removed, or at least made ;; to use lisp-level optimization policy rather - ;; than what they do now, which is LLVM stuff. - (optimize t) + ;; than what it does now, which is LLVM stuff. (optimize-level *optimization-level*) &allow-other-keys) ;; These are all just passed along to other functions. (declare (ignore output-file environment type - image-startup-position optimize optimize-level)) + image-startup-position optimize-level)) "See CLHS compile-file." (with-compilation-unit () (let* ((output-path (apply #'compile-file-pathname input-file args)) @@ -286,7 +279,6 @@ Compile a Lisp source stream and return a corresponding LLVM module." (defun compile-stream/serial (input-stream output-path &rest args &key - (optimize t) (optimize-level *optimization-level*) (output-type *default-output-type*) ;; type can be either :kernel or :user @@ -304,7 +296,6 @@ Compile a Lisp source stream and return a corresponding LLVM module." (let ((module (compile-stream-to-module input-stream :environment environment :image-startup-position image-startup-position - :optimize optimize :optimize-level optimize-level))) (compile-file-output-module module output-path output-type type diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index 62182d8ded..8e481934b3 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -4,18 +4,11 @@ (defparameter *lambda-args-num* 0) -(defmacro with-module (( &key module - (optimize nil) - (optimize-level '*optimization-level*) - dry-run) &rest body) +(defmacro with-module ((&key module) &rest body) `(let* ((*the-module* ,module)) (or *the-module* (error "with-module *the-module* is NIL")) - (multiple-value-prog1 - (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) - ,@body) - (cmp-log "About to optimize-module%N") - ;;(cmp-log-dump-module ,module) - (when (and ,optimize ,optimize-level (null ,dry-run)) (funcall ,optimize ,module ,optimize-level ))))) + (with-irbuilder ((llvm-sys:make-irbuilder (thread-local-llvm-context))) + ,@body))) (defun compile-with-hook (compile-hook definition env) (with-compilation-unit () diff --git a/src/lisp/kernel/cmp/disassemble.lisp b/src/lisp/kernel/cmp/disassemble.lisp index af22d2aa48..cd2ad84e1b 100644 --- a/src/lisp/kernel/cmp/disassemble.lisp +++ b/src/lisp/kernel/cmp/disassemble.lisp @@ -52,11 +52,11 @@ (disassemble-assembly start end)) (format t "; could not locate code object (bug?)~%")))))))) -(defun potentially-save-module () +(defun potentially-save-module (&optional (module *the-module*)) (when *save-module-for-disassemble* (setq *saved-module-from-clasp-jit* (with-output-to-string (*standard-output*) - (llvm-sys:dump-module *the-module* *standard-output*))))) + (llvm-sys:dump-module module *standard-output*))))) ;;; should work for both lambda expressions and interpreted functions. (defun disassemble-to-ir (thing) diff --git a/src/lisp/kernel/lsp/fli.lisp b/src/lisp/kernel/lsp/fli.lisp index a53d488bb5..b32bb9f710 100644 --- a/src/lisp/kernel/lsp/fli.lisp +++ b/src/lisp/kernel/lsp/fli.lisp @@ -466,7 +466,7 @@ (id (cmp::next-jit-compile-counter)) (varname (format nil "callback-lisp-function-~d" id)) (callback-name (format nil "callback-~d" id))) - (cmp::with-module (:module module :optimize nil) + (cmp::with-module (:module module) (let ((var (llvm-sys:make-global-variable module cmp:%t*% nil 'llvm-sys:external-linkage (llvm-sys:undef-value-get From f36d8b6ca2fcb5a90eef1f4068c3feca3579cfb0 Mon Sep 17 00:00:00 2001 From: Bike Date: Thu, 9 May 2024 08:36:09 -0400 Subject: [PATCH 22/37] Make arguments available in optimized function backtraces As long as the register save area is generated we should be able to get arguments. I honestly don't understand why the meat of this change - getting the function description from the closure - is necessary, since I would think the fd is available from the entry point. Whatever. --- src/core/backtrace.cc | 39 ++++++++------------------------------- 1 file changed, 8 insertions(+), 31 deletions(-) diff --git a/src/core/backtrace.cc b/src/core/backtrace.cc index 01159f1dd9..622390b32e 100644 --- a/src/core/backtrace.cc +++ b/src/core/backtrace.cc @@ -232,34 +232,24 @@ T_sp dwarf_ep(size_t frameIndex, llvmo::ObjectFile_sp ofi, llvmo::DWARFContext_s return nil(); } -__attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const char* string, T_sp name, bool XEPp, int arityCode, +__attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, int arityCode, void* frameptr, int32_t offset32, T_sp& closure, T_sp& args, int64_t patch_point_id) { MaybeTrace trace(__FUNCTION__); int64_t offset64 = static_cast(offset32); - D(printf("%s%s:%d:%s fi=%lu ip=%p fp = %p patch_point_id 0x%lx offset64 = %ld\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, fi, ip, frameptr, patch_point_id, offset64);); int64_t arity_code; if (frameptr && is_entry_point_arity(patch_point_id, arity_code)) { - D(printf("%s%s:%d:%s entry_point arity_code %ld\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, arity_code);); T_O** register_save_area = (T_O**)((intptr_t)frameptr + offset64); - D(printf("%s%s:%d:%s fi=%lu ip=%p fp %p arity_code %ld rsa=%p %s XEP(y=%d,a=%d) ", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, fi, ip, frameptr, arity_code, register_save_area, _rep_(name).c_str(), XEPp, arityCode);); - D(if (string) printf("%s", string);); - D(printf("\n");); T_sp tclosure((gc::Tagged)register_save_area[LCC_CLOSURE_REGISTER]); if (!gc::IsA(tclosure)) { - D(printf("%s%s:%d:%s bad tclosure %p\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, tclosure.raw_());); fprintf(stderr, "%s:%d:%s When trying to get arguments from CL frame read what should be a closure %p but it isn't\n", __FILE__, __LINE__, __FUNCTION__, tclosure.raw_()); return false; } closure = tclosure; - D(printf("%s%s:%d:%s closure = %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(closure).c_str());); if (arity_code == 0) { // For the general entry point the registers are (closure, nargs, arg_ptr) size_t nargs = (size_t)(register_save_area[LCC_NARGS_REGISTER]); - D(printf("%s%s:%d:%s nargs = %lu\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs);); if (nargs > 256) { fprintf(stderr, "%s:%d:%s There are too many arguments %lu\n", __FILE__, __LINE__, __FUNCTION__, nargs); return false; @@ -268,12 +258,9 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const // Get the arg ptr from the register save area T_O** arg_ptr = (T_O**)register_save_area[LCC_ARGS_PTR_REGISTER]; // get the args from the arg_ptr - D(printf("%s%s:%d:%s About to read %lu xep args\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs);); for (size_t i = 0; i < nargs; ++i) { T_O* rarg = arg_ptr[i]; T_sp temp((gctools::Tagged)rarg); - D(printf("%s%s:%d:%s read xep(general) arg %lu -> %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, i, - _rep_(temp).c_str());); largs << temp; } args = largs.cons(); @@ -282,16 +269,12 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const size_t arity_nargs = arity_code - 1; ASSERT(ENTRY_POINT_ARITY_BEGIN == 0); // maybe in the future we may want to support something else size_t nargs = arity_nargs + ENTRY_POINT_ARITY_BEGIN; - D(printf("%s%s:%d:%s About to read %lu xep%lu args\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs, - arity_code - 1);); // Get the first args from the register save area ql::list largs; size_t args_in_rsa = std::min(nargs, (size_t)(LCC_WORDS_IN_REGISTER_SAVE_AREA - 1)); // -1 to remove closure arg int args_on_stack = nargs - (LCC_WORDS_IN_REGISTER_SAVE_AREA - 1); for (size_t i = 0; i < args_in_rsa; ++i) { T_sp temp((gctools::Tagged)(register_save_area[i + 1])); // +1 to skip closure arg - D(printf("%s%s:%d:%s read xep%lu arg %lu -> %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, nargs, i, - _rep_(temp).c_str());); largs << temp; } // and the rest from the stack frame if we support xepN functions that exhaust the available register arguments @@ -311,10 +294,8 @@ __attribute__((optnone)) static bool args_from_offset(size_t fi, void* ip, const } return true; } else { - D(printf("%s%s:%d:%s entry_point no stackmap entry\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__);); return false; } - D(printf("%s%s:%d:%s Extracted args: %s\n", trace.spaces().c_str(), __FILE__, __LINE__, __FUNCTION__, _rep_(args).c_str());); } bool sanity_check_args(void* frameptr, int32_t offset32, int64_t patch_point_id) { @@ -351,9 +332,9 @@ bool sanity_check_args(void* frameptr, int32_t offset32, int64_t patch_point_id) return true; // information not being available is unfortunate but sane } -__attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, const char* string, bool XEPp, int arityCode, +__attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, int arityCode, void* functionStartAddress, llvmo::ObjectFile_sp ofi, - T_sp& functionDescriptionOrNil, void* frameptr, T_sp& closure, T_sp& args) { + T_sp functionDescriptionOrNil, void* frameptr, T_sp& closure, T_sp& args) { MaybeTrace trace(__FUNCTION__); if (!functionStartAddress) { D(printf("%s:%d:%s functionStartAddress is NULL returning\n", __FILE__, __LINE__, __FUNCTION__);); @@ -366,16 +347,10 @@ __attribute__((optnone)) static bool args_for_function(size_t fi, void* ip, cons } uintptr_t stackmap_end = stackmap_start + ofi->_StackmapSize; bool args_available = false; - T_sp name = nil(); - ; - if (gc::IsA(functionDescriptionOrNil)) - name = gc::As_unsafe(functionDescriptionOrNil); auto thunk = [&](size_t _, const smStkSizeRecord& function, int32_t offsetOrSmallConstant, int64_t patchPointId) { if (function.FunctionAddress == (uintptr_t)functionStartAddress) { MaybeTrace tracel("functionStartAddress_thunk"); - D(printf("%s%s:%d:%s function.FunctionAddress = %p functionStartAddress = %p\n", trace.spaces().c_str(), __FILE__, __LINE__, - __FUNCTION__, (void*)function.FunctionAddress, functionStartAddress);); - if (args_from_offset(fi, ip, string, name, XEPp, arityCode, frameptr, offsetOrSmallConstant, closure, args, patchPointId)) + if (args_from_offset(fi, ip, arityCode, frameptr, offsetOrSmallConstant, closure, args, patchPointId)) args_available |= true; return; } @@ -404,13 +379,15 @@ static DebuggerFrame_sp make_lisp_frame(size_t frameIndex, void* absolute_ip, co else if (gc::IsA(ep)) functionDescriptionOrNil = gc::As_unsafe(ep)->functionDescription(); T_sp closure = nil(), args = nil(); - bool args_available = args_for_function(frameIndex, absolute_ip, string, XEPp, arityCode, functionStartAddress, ofi, + bool args_available = args_for_function(frameIndex, absolute_ip, arityCode, functionStartAddress, ofi, functionDescriptionOrNil, fbp, closure, args); T_sp fname = nil(); if (gc::IsA(functionDescriptionOrNil)) { fname = gc::As_unsafe(functionDescriptionOrNil)->functionName(); } else if (args_available && gc::IsA(closure)) { - fname = gc::As_unsafe(closure)->functionName(); + Function_sp fclos = closure.as_unsafe(); + functionDescriptionOrNil = fclos->fdesc(); + fname = fclos->functionName(); } if (fname.nilp() && string) { fname = SimpleBaseString_O::make(std::string(string)); From 8f4d012d50d172e6c3fbbdcf82afefb3994cf94d Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 10 May 2024 10:30:07 -0400 Subject: [PATCH 23/37] Actually use LLVM optimizations buildPerModuleDefaultPipeline does not operate by side effect. We should probably wrap all the optimization pipeline/passes stuff, or at least what we use, so as to experiment with what actually helps. Right now we just do -O3 depending on a dynamic variable, which isn't amazing. I also disabled the inline threshold change. I'm seeing plenty of inlining even with the default threshold. --- src/llvmo/llvmoExpose.cc | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index 72364adbe5..d8ca88ab1a 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -111,6 +111,7 @@ Error enableObjCRegistration(const char* PathToLibObjC); #include #include // #include // will be llvm/IR was llvm/Assembly +#include #include #include @@ -4206,14 +4207,15 @@ CL_DEFUN void llvm_sys__optimizeModule(llvm::Module* module, int level) { llvm::FunctionAnalysisManager FAM; llvm::CGSCCAnalysisManager CGAM; llvm::ModuleAnalysisManager MAM; - +/* llvm::PipelineTuningOptions pipeline_opts; #if LLVM_VERSION_MAJOR > 15 pipeline_opts.InlinerThreshold = 0; #endif llvm::PassBuilder PB(NULL, pipeline_opts); - llvm::ModulePassManager MPM; +*/ + llvm::PassBuilder PB; PB.registerModuleAnalyses(MAM); PB.registerCGSCCAnalyses(CGAM); @@ -4237,7 +4239,13 @@ CL_DEFUN void llvm_sys__optimizeModule(llvm::Module* module, int level) { } #endif - PB.buildPerModuleDefaultPipeline(opt_level); + // In LLVM16, buildPerModuleDefaultPipeline does not work with O0. + // This was changed in 17 and up. +#if LLVM_VERSION_MAJOR < 17 + llvm::ModulePassManager MPM = opt_level == OptimizationLevel::O0 ? PB.buildO0DefaultPipeline(opt_level) : PB.buildPerModuleDefaultPipeline(opt_level); +#else + llvm::ModulePassManager MPM = PB.buildPerModuleDefaultPipeline(opt_level); +#endif MPM.run(*module, MAM); } From 5fd7f04df7693f9a41b4e90fbef8710bca8242b1 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 10 May 2024 13:27:27 -0400 Subject: [PATCH 24/37] Delete inline AST re-sourcing code It's ugly and I have a better way. Hopefully. Not yet. This means that inline function source locations are in the wrong place. --- src/lisp/kernel/cleavir/inline-prep.lisp | 114 +---------------------- src/lisp/kernel/cleavir/inline.lisp | 1 - 2 files changed, 1 insertion(+), 114 deletions(-) diff --git a/src/lisp/kernel/cleavir/inline-prep.lisp b/src/lisp/kernel/cleavir/inline-prep.lisp index 9cbd3a7f4d..7d18b9cf48 100644 --- a/src/lisp/kernel/cleavir/inline-prep.lisp +++ b/src/lisp/kernel/cleavir/inline-prep.lisp @@ -26,46 +26,6 @@ ;; Add other clauses here (t #+(or)(warn "Add support for proclaim ~s~%" decl))))) -;;; Given a FUNCTION-AST, return the function-scope-info to insert into its body ASTs. -;;; or NIL if there's no source info. -(defun compute-fsi (ast) - (let ((orig (let ((orig (origin-source (cleavir-ast:origin ast)))) - (cond ((consp orig) (car orig)) - ((null orig) core:*current-source-pos-info*) - (t orig))))) - ;; See usage in cmp/debuginfo.lisp - (list (jit-function-name (cleavir-ast:name ast)) - (core:source-pos-info-lineno orig) - (core:source-pos-info-file-handle orig)))) - -;;; Stuff to put function scope infos into inline ast SPIs. -(defun insert-function-scope-info-into-spi (spi fsi) - ;; If something already has an FSI, we're in a nested inline AST - ;; and don't want to interfere with it. - (unless (core:source-pos-info-function-scope spi) - (core:setf-source-pos-info-function-scope spi fsi))) -(defun insert-function-scope-info-into-ast (ast fsi) - (let ((orig (origin-source (cleavir-ast:origin ast)))) - (cond ((consp orig) - (insert-function-scope-info-into-spi (car orig) fsi) - (insert-function-scope-info-into-spi (cdr orig) fsi)) - ((null orig) - (return-from insert-function-scope-info-into-ast ast)) - (t - (insert-function-scope-info-into-spi orig fsi))))) -(defun fix-inline-ast (ast) - (check-type ast cleavir-ast:function-ast) - (let ((fsi (compute-fsi ast))) - (unless (null fsi) - (insert-function-scope-info-into-ast ast fsi) - (labels ((aux (ast) - (typecase ast - (cleavir-ast:function-ast (fix-inline-ast ast)) - (t (insert-function-scope-info-into-ast ast fsi) - (cleavir-ast:map-children #'aux ast))))) - (cleavir-ast:map-children #'aux ast)))) - ast) - ;;; Bound by cst->ast to preserve source info. (defvar *compiling-cst* nil) @@ -80,7 +40,7 @@ (cst (if *compiling-cst* (cst:reconstruct *clasp-system* form *compiling-cst*) (cst:cst-from-expression form)))) - (fix-inline-ast (cst->ast cst env)))) + (cst->ast cst env))) ;;; Incorporated into DEFUN expansion (see lsp/evalmacros.lisp) (defun defun-inline-hook (name function-form env) @@ -95,75 +55,3 @@ (eval-when (:compile-toplevel :execute :load-toplevel) (setq core:*proclaim-hook* 'proclaim-hook)) - -;;; The following code sets up the chain of inlined-at info in AST origins. - -;;; Basically we want to recurse until we hit a SPI with no inlined-at, -;;; and set its inlined-at to the provided value. Also we clone everything, -;;; and memoize to avoid cloning too much. -(defun fix-inline-source-position (spi inlined-at table) - (or (gethash spi table) - (setf (gethash spi table) - (let ((clone (core:source-pos-info-copy spi))) - (core:setf-source-pos-info-inlined-at - clone - (let ((next (core:source-pos-info-inlined-at clone))) - (if next - (fix-inline-source-position next inlined-at table) - inlined-at))) - clone)))) - -(defun %allocate-copy (origin inlined-at table) - (etypecase origin - (null nil) - (cst:cons-cst (make-instance 'cst:cons-cst :raw (cst:raw origin))) - (cst:atom-cst (make-instance 'cst:atom-cst :raw (cst:raw origin))) - (cons - (cons (copy-origin-fixing-sources (car origin) inlined-at table) - (copy-origin-fixing-sources (cdr origin) inlined-at table))) - (core:source-pos-info - (let ((clone (core:source-pos-info-copy origin))) - (core:setf-source-pos-info-inlined-at - clone - (let ((next (core:source-pos-info-inlined-at clone))) - (if next - (copy-origin-fixing-sources next inlined-at table) - inlined-at))) - clone)))) - -(defun %initialize-copy (origin copy inlined-at table) - (typecase origin - (cst:cons-cst - (let ((car (copy-origin-fixing-sources (cst:first origin) - inlined-at table)) - (cdr (copy-origin-fixing-sources (cst:rest origin) - inlined-at table)) - (source (copy-origin-fixing-sources (cst:source origin) - inlined-at table))) - (reinitialize-instance copy :first car :rest cdr :source source))) - (cst:atom-cst - (let ((source (copy-origin-fixing-sources (cst:source origin) - inlined-at table))) - (reinitialize-instance copy :source source))))) - -(defun copy-origin-fixing-sources (origin inlined-at - &optional (table - (make-hash-table :test #'eq))) - (multiple-value-bind (copy presentp) - (gethash origin table) - (if presentp - copy - (let ((copy (%allocate-copy origin inlined-at table))) - (setf (gethash origin table) copy) - ;; For CSTs, initialize the copy now that subforms can refer to the - ;; existing entry (done this way in case of cycles) - (%initialize-copy origin copy inlined-at table) - copy)))) - -(defmethod cleavir-ast-to-bir:inline-origin (origin inlined-at (system clasp)) - (let ((inlined-at (origin-spi (origin-source inlined-at)))) - (if inlined-at - (progn - (check-type inlined-at core:source-pos-info) - (copy-origin-fixing-sources origin inlined-at)) - origin))) diff --git a/src/lisp/kernel/cleavir/inline.lisp b/src/lisp/kernel/cleavir/inline.lisp index 546c0e48a2..7d59cca581 100644 --- a/src/lisp/kernel/cleavir/inline.lisp +++ b/src/lisp/kernel/cleavir/inline.lisp @@ -11,7 +11,6 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (setf cmp::*debug-create-call* nil)) -#+(or) (eval-when (:compile-toplevel :execute :load-toplevel) (setq core:*defun-inline-hook* 'defun-inline-hook)) From 97617d05b2a7bb5cfe6bfffe9d8d59f6b51c9b87 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 10 May 2024 13:42:10 -0400 Subject: [PATCH 25/37] new debuginfo: handle functions with different source files you know, for inlining. This fixes source info for inlined calls. (If LLVM is doing the inlining, anyway.) --- src/lisp/kernel/cleavir/debuginfo.lisp | 34 +++++++++++++++++++------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index 32e1ff5ddd..dc1fefaf9f 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -25,6 +25,16 @@ (llvm-sys:dibuilder/create-file *dibuilder* filename directory nil source))) +;;; Hash table from pathnames to DIFiles. (So, use an EQUAL test.) +;;; A source file can have other DIFiles in it due to inlining, so this is +;;; pretty important. +(defvar *difile-cache*) + +(defun ensure-difile (pathname &key (source ";;")) + (or (gethash pathname *difile-cache*) + (setf (gethash pathname *difile-cache*) + (make-difile pathname :source source)))) + (defun add-module-di-flags (module) ;; add the flag that defines the Dwarf Version ;; FIXME: Why do we use a pretty old DWARF version here? @@ -59,11 +69,12 @@ `(flet ((,gbody () (progn ,@body))) (if *generate-dwarf* (let* ((,gmodule ,llvm-ir-module) - (*dibuilder* (make-dibuilder ,gmodule))) + (*dibuilder* (make-dibuilder ,gmodule)) + (*difile-cache* (make-hash-table :test #'equal))) (unwind-protect ,(if filep `(let ((*dbg-current-scope* - (make-difile ,file :source ,source))) + (ensure-difile ,file :source ,source))) (install-compile-unit *dibuilder* *dbg-current-scope*) (,gbody)) @@ -177,13 +188,15 @@ (values (core:file-scope-pathname (core:file-scope handle)) lineno column))) -(defun create-di-main-function (ir name - &key (difile *dbg-current-scope*) - (linkage-name name)) +(defun create-di-main-function (ir name &key (linkage-name name)) (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (path (core:file-scope-pathname + (core:file-scope + (core:source-pos-info-file-handle spi)))) + (difile (ensure-difile path)) (lineno (core:source-pos-info-lineno spi))) (llvm-sys:dibuilder/create-function - *dibuilder* *dbg-current-scope* name linkage-name difile lineno + *dibuilder* difile name linkage-name difile lineno (create-di-main-function-type ir) lineno (di-zeroflags) (dispflags 'llvm-sys:dispflag-definition) nil nil nil nil ""))) @@ -209,12 +222,15 @@ (llvm-sys:get-or-create-type-array *dibuilder* params) (di-zeroflags) 0))) -(defun create-di-xep (ir name arity &key (difile *dbg-current-scope*) - (linkage-name name)) +(defun create-di-xep (ir name arity &key (linkage-name name)) (let* ((spi (origin-spi (origin-source (bir:origin ir)))) + (path (core:file-scope-pathname + (core:file-scope + (core:source-pos-info-file-handle spi)))) + (difile (ensure-difile path)) (lineno (core:source-pos-info-lineno spi))) (llvm-sys:dibuilder/create-function - *dibuilder* *dbg-current-scope* name linkage-name difile lineno + *dibuilder* difile name linkage-name difile lineno (if (eq arity :general-entry) (create-di-gxep-type) (create-di-nxep-type arity)) From 9d37198fa81dd032d118ebd994aa2b2676dbb32a Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 10 May 2024 15:51:08 -0400 Subject: [PATCH 26/37] Make defaultEntryAddress/arityEntryAddress functions non virtual arityEntryAddress is something I added while debugging backtraces and I suppose we may as well keep it around. --- include/clasp/core/function.h | 9 +++++---- src/core/function.cc | 17 ++++++++--------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/include/clasp/core/function.h b/include/clasp/core/function.h index f99f503103..6167a4faea 100644 --- a/include/clasp/core/function.h +++ b/include/clasp/core/function.h @@ -228,7 +228,11 @@ class SimpleFun_O : public Function_O { SimpleFun_O(FunctionDescription_sp fdesc, T_sp code, const ClaspXepTemplate& entry_point); CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; }; - virtual Pointer_sp defaultEntryAddress() const; + // These two are useful for debugging things at a low level. + // They're unsafe. + Pointer_sp defaultEntryAddress() const; + Pointer_sp arityEntryAddress(size_t arity) const; + // Necessary since we have templated subclasses in clbind. // Doing so means the static analyzer marks SimpleFun as a // TemplatedKind, which makes the GC use templatedSizeof to @@ -293,7 +297,6 @@ class CoreFun_O : public General_O { public: CL_DEFMETHOD FunctionDescription_sp functionDescription() const { return this->_FunctionDescription; }; virtual void fixupInternalsForSnapshotSaveLoad(snapshotSaveLoad::Fixup* fixup); - virtual Pointer_sp defaultEntryAddress() const; string __repr__() const; }; @@ -337,7 +340,6 @@ class SimpleCoreFun_O : public SimpleFun_O { static SimpleCoreFun_sp make(FunctionDescription_sp fdesc, ClaspCoreFunction main, ClaspXepAnonymousFunction* xep); public: - virtual Pointer_sp defaultEntryAddress() const; llvmo::ObjectFile_sp code() const; CoreFun_sp localFun() const; string __repr__() const; @@ -372,7 +374,6 @@ class BytecodeSimpleFun_O : public SimpleFun_O { unsigned int bytecodeSize, BytecodeTrampolineFunction trampoline); public: - virtual Pointer_sp defaultEntryAddress() const; BytecodeModule_sp code() const; string __repr__() const; diff --git a/src/core/function.cc b/src/core/function.cc index c57cf1ac00..40e1c7300b 100644 --- a/src/core/function.cc +++ b/src/core/function.cc @@ -53,6 +53,13 @@ namespace core { bytecode_trampoline_function bytecode_trampoline = bytecode_call; // default +CL_DEFMETHOD Pointer_sp SimpleFun_O::defaultEntryAddress() const { + return Pointer_O::create((void*)(this->_EntryPoints[0])); +} +CL_DEFMETHOD Pointer_sp SimpleFun_O::arityEntryAddress(size_t arity) const { + return Pointer_O::create((void*)(this->_EntryPoints[arity+1])); +} + void SimpleFun_O::fixupOneCodePointer(snapshotSaveLoad::Fixup* fixup, void** ptr) { #ifdef USE_PRECISE_GC if (snapshotSaveLoad::operation(fixup) == snapshotSaveLoad::InfoOp) { @@ -72,8 +79,6 @@ void SimpleFun_O::fixupOneCodePointer(snapshotSaveLoad::Fixup* fixup, void** ptr #endif } -CL_DEFMETHOD Pointer_sp SimpleFun_O::defaultEntryAddress() const { SUBCLASS_MUST_IMPLEMENT(); } - SimpleFun_O::SimpleFun_O(FunctionDescription_sp fdesc, T_sp code, const ClaspXepTemplate& entry_point) : Function_O(this), _FunctionDescription(fdesc), _Code(code), _EntryPoints(entry_point) { @@ -125,12 +130,10 @@ CoreFun_O::CoreFun_O(FunctionDescription_sp fdesc, T_sp code, llvmo::validateEntryPoint(code, entry_point); } - void BytecodeSimpleFun_O::set_trampoline(Pointer_sp trampoline) { +void BytecodeSimpleFun_O::set_trampoline(Pointer_sp trampoline) { this->_Trampoline = (BytecodeTrampolineFunction)trampoline->ptr(); } -Pointer_sp SimpleCoreFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_EntryPoints[0]); }; - CL_LISPIFY_NAME("simple-core-fun/code"); CL_DEFMETHOD llvmo::ObjectFile_sp SimpleCoreFun_O::code() const { @@ -142,10 +145,6 @@ CL_LISPIFY_NAME("simple-core-fun-local-fun"); CL_DEFMETHOD CoreFun_sp SimpleCoreFun_O::localFun() const { return this->_localFun; } -Pointer_sp CoreFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_Entry); }; - -Pointer_sp BytecodeSimpleFun_O::defaultEntryAddress() const { return Pointer_O::create((void*)this->_EntryPoints[0]); }; - CL_LISPIFY_NAME("bytecode-simple-fun/code"); CL_DEFMETHOD BytecodeModule_sp BytecodeSimpleFun_O::code() const { From d3b1ff47794bb6d42914710a0d211b3d6b5cf463 Mon Sep 17 00:00:00 2001 From: Bike Date: Mon, 13 May 2024 10:16:42 -0400 Subject: [PATCH 27/37] Update Cleavir --- repos.sexp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/repos.sexp b/repos.sexp index f13bb05d22..cc5aa1cff2 100644 --- a/repos.sexp +++ b/repos.sexp @@ -108,7 +108,7 @@ (:name :cleavir :repository "https://github.com/s-expressionists/Cleavir.git" :directory "src/lisp/kernel/contrib/Cleavir/" - :commit "e41eae5dcac98532148ffc9c524fbfefe70c2965") + :commit "18129fc245603a27ff49e4705e47a4470d6f2ce9") (:name :closer-mop :repository "https://github.com/pcostanza/closer-mop.git" :directory "src/lisp/kernel/contrib/closer-mop/" From 2a081e7d4bf9aee5a95ea5a7e4365923664f5494 Mon Sep 17 00:00:00 2001 From: Bike Date: Mon, 13 May 2024 13:13:07 -0400 Subject: [PATCH 28/37] clasp-cleavir: allow non-object rtypes in come-from having them is probably inefficient but there's no reason we can't generate the appropriate code to box and unbox. The ANSI test MISC-105 was failing without this, because with later inlining an unwind actually remains an unwind. Something to look into before merge. --- src/lisp/kernel/cleavir/landing-pad.lisp | 18 +++++++---- src/lisp/kernel/cleavir/translate.lisp | 41 ++++++++++++++++-------- 2 files changed, 38 insertions(+), 21 deletions(-) diff --git a/src/lisp/kernel/cleavir/landing-pad.lisp b/src/lisp/kernel/cleavir/landing-pad.lisp index 04b5092b26..ab02129e26 100644 --- a/src/lisp/kernel/cleavir/landing-pad.lisp +++ b/src/lisp/kernel/cleavir/landing-pad.lisp @@ -234,13 +234,17 @@ (let ((rt (cc-bmir:rtype (first (bir:inputs (first destinations)))))) (cond ((eq rt :multiple-values) tmv) - ((equal rt '(:object)) - (cmp:irc-tmv-primary tmv)) - ((null rt) nil) ; redundant with nonlocal-valued-p - ((every (lambda (x) (eq x :object)) rt) - (list* (cmp:irc-tmv-primary tmv) - (loop for i from 1 below (length rt) - collect (cmp:irc-t*-load (return-value-elt i))))) + ((null rt) nil) + ((and (consp rt) (null (cdr rt))) + (cast-one :object (first rt) + (cmp:irc-tmv-primary tmv))) + ((listp rt) + (list* (cast-one :object (first rt) + (cmp:irc-tmv-primary tmv)) + (loop for i from 1 + for drt in (rest rt) + for v = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object drt v) ))) (t (error "BUG: Bad rtype ~a" rt)))))) (go-index (cmp:irc-typed-load cmp:%go-index% *go-index.slot*)) (sw (cmp:irc-switch go-index next ndestinations))) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 0910814cd5..ade605ef5e 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -388,14 +388,19 @@ (let ((mv (restore-multiple-value-0)) (rt (cc-bmir:rtype phi))) (cond ((null rt)) - ((equal rt '(:object)) - (phi-out (cmp:irc-tmv-primary mv) phi block)) ((eq rt :multiple-values) (phi-out mv phi block)) - ((every (lambda (x) (eq x :object)) rt) + ((and (consp rt) (null (cdr rt))) + (phi-out (cast-one :object (first rt) + (cmp:irc-tmv-primary mv)) + phi block)) + ((listp rt) (phi-out - (list* (cmp:irc-tmv-primary mv) - (loop for i from 1 below (length rt) - collect (cmp:irc-t*-load (return-value-elt i)))) + (list* (cast-one :object (first rt) + (cmp:irc-tmv-primary mv)) + (loop for srt in (rest rt) + for i from 1 + for v = (cmp:irc-t*-load (return-value-elt i)) + collect (cast-one :object srt v))) phi block)) (t (error "BUG: Bad rtype ~a" rt))))) @@ -481,17 +486,25 @@ ;; Force the return values into a tmv for transmission. (rrv (when rv (let ((rt (cc-bmir:rtype rv))) - (cond ((equal rt '(:object)) - (cmp:irc-make-tmv (%size_t 1) (in rv))) - ((eq rt :multiple-values) (in rv)) + (cond ((eq rt :multiple-values) (in rv)) ((null rt) (cmp:irc-make-tmv (%size_t 0) (%nil))) - ((every (lambda (x) (eq x :object)) rt) - (let ((vals (in rv)) - (nvals (length rt))) + ((and (consp rt) (null (cdr rt))) + (let ((srt (first rt)) + (val (in rv))) + (cmp:irc-make-tmv (%size_t 1) + (cast-one srt :object val)))) + ((listp rt) + (let* ((vals (in rv)) + (nvals (length rt)) + (srt1 (first rt)) + (c1 (cast-one srt1 :object (first vals)))) (loop for i from 1 below nvals for v in (rest vals) - do (cmp:irc-store v (return-value-elt i))) - (cmp:irc-make-tmv (%size_t nvals) (first vals)))) + for srt in (rest rt) + for e = (return-value-elt i) + for c = (cast-one srt :object v) + do (cmp:irc-store v e)) + (cmp:irc-make-tmv (%size_t nvals) c1))) (t (error "BUG: Bad rtype ~a" rt)))))) (destination (bir:destination instruction)) (destination-id (get-destination-id destination))) From 64fa5e13db57c94c97407a103d1bc714f995b7f3 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 15 May 2024 10:06:41 -0400 Subject: [PATCH 29/37] Fix SPI lineno extraction Missed a value. Oops --- src/lisp/kernel/cleavir/debuginfo.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index dc1fefaf9f..345b456cfb 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -183,8 +183,9 @@ ;;; Given a source-pos-info, return a pathname, lineno, and column ;;; as values. FIXME: This integer file handle thing is really silly. (defun spi-info (spi) - (multiple-value-bind (handle lineno column) + (multiple-value-bind (handle filepos lineno column) (core:source-pos-info-unpack spi) + (declare (ignore filepos)) (values (core:file-scope-pathname (core:file-scope handle)) lineno column))) From 889f73b0bf15bbfe57f464e7089ddea82cdbedad Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 15 May 2024 10:54:16 -0400 Subject: [PATCH 30/37] Handle logical pathnames in debug info at lower level rather than explicitly specifying :source or w/e --- src/lisp/kernel/cleavir/debuginfo.lisp | 30 ++++++++++++------- src/lisp/kernel/cleavir/translate.lisp | 13 ++++---- .../kernel/cmp/compile-file-parallel.lisp | 2 +- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index 345b456cfb..cf503e1048 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -17,11 +17,19 @@ (defun make-dibuilder (module) (llvm-sys:make-dibuilder module)) -(defun make-difile (pathname &key (source ";;")) - (let ((filename (file-namestring pathname)) - (directory - (namestring - (make-pathname :name nil :type nil :defaults pathname)))) +(defun make-difile (pathname) + (let* ((physical (translate-logical-pathname pathname)) + (source (if (core:logical-pathname-p pathname) + (format nil ";; LOGICAL-PATHNAME=~a~%" + (namestring pathname)) + ;; LLVM expects that either all locations have + ;; a SOURCE or none of them do, so we always + ;; put in something. + ";;")) + (filename (file-namestring physical)) + (directory + (namestring + (make-pathname :name nil :type nil :defaults physical)))) (llvm-sys:dibuilder/create-file *dibuilder* filename directory nil source))) @@ -30,10 +38,10 @@ ;;; pretty important. (defvar *difile-cache*) -(defun ensure-difile (pathname &key (source ";;")) +(defun ensure-difile (pathname) (or (gethash pathname *difile-cache*) (setf (gethash pathname *difile-cache*) - (make-difile pathname :source source)))) + (make-difile pathname)))) (defun add-module-di-flags (module) ;; add the flag that defines the Dwarf Version @@ -61,7 +69,7 @@ ;;; also bind *dbg-current-scope* to a new DIFile. ;;; Afterwords finalize the DIBuilder, and add debug flags to the module. (defmacro with-debuginfo ((llvm-ir-module - &key (file nil filep) (source ";;")) + &key (path nil pathp)) &body body) (let ((gbody (gensym "BODY")) (gmodule (gensym "MODULE"))) @@ -72,9 +80,9 @@ (*dibuilder* (make-dibuilder ,gmodule)) (*difile-cache* (make-hash-table :test #'equal))) (unwind-protect - ,(if filep + ,(if pathp `(let ((*dbg-current-scope* - (ensure-difile ,file :source ,source))) + (ensure-difile ,path))) (install-compile-unit *dibuilder* *dbg-current-scope*) (,gbody)) @@ -123,7 +131,7 @@ &key scope (alignment 64)) ;; These types are used by the runtime rather than being defined ;; anywhere, so the file spec is a little dumb. - (let ((file (make-difile "-implicit-")) (lineno 0)) + (let ((file (make-difile #p"-implicit-")) (lineno 0)) (llvm-sys:create-struct-type dibuilder scope name file lineno ;; WARNING: This may not work in general, diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index ade605ef5e..92440a4dfe 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1871,14 +1871,13 @@ COMPILE-FILE will use the default *clasp-env*." (pathname (let ((origin (origin-source (bir:origin bir)))) (if origin - (namestring - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin)))) - "repl-code")))) + (core:file-scope-pathname + (core:file-scope + (core:source-pos-info-file-handle origin))) + #p"repl-code")))) (cmp::with-module (:module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) - (with-debuginfo (module :file pathname) + (with-debuginfo (module :path pathname) (multiple-value-prog1 (literal:with-rtv (translate bir :linkage linkage :abi abi)) @@ -1952,7 +1951,7 @@ COMPILE-FILE will use the default *clasp-env*." (eclector.reader:*client* cmp:*cst-client*) (cst-to-ast:*compiler* 'cl:compile-file)) (with-debuginfo (cmp:*the-module* - :file (namestring cmp::*compile-file-source-debug-pathname*)) + :path cmp::*compile-file-source-debug-pathname*) (loop ;; Required to update the source pos info. FIXME!? (peek-char t source-sin nil) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index ebdfd00d51..70fde5e923 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -153,7 +153,7 @@ (core:*current-source-pos-info* (ast-job-source-pos-info job))) (with-module (:module module) (with-make-new-run-all (run-all-function (format nil "module~a" (ast-job-form-index job))) - (clasp-cleavir::with-debuginfo (module :file (namestring cmp::*compile-file-source-debug-pathname*)) + (clasp-cleavir::with-debuginfo (module :path cmp::*compile-file-source-debug-pathname*) (with-literal-table (:id (ast-job-form-index job)) (core:with-memory-ramp (:pattern 'gctools:ramp) (literal:arrange-thunk-as-top-level From 9a6247f4d0303825757f265b220d601304e57530 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 15 May 2024 10:59:10 -0400 Subject: [PATCH 31/37] Use ensure-difile uniformly --- src/lisp/kernel/cleavir/debuginfo.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index cf503e1048..b72faf74b3 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -131,7 +131,7 @@ &key scope (alignment 64)) ;; These types are used by the runtime rather than being defined ;; anywhere, so the file spec is a little dumb. - (let ((file (make-difile #p"-implicit-")) (lineno 0)) + (let ((file (ensure-difile #p"-implicit-")) (lineno 0)) (llvm-sys:create-struct-type dibuilder scope name file lineno ;; WARNING: This may not work in general, From 119fe7e0d62c87f508991b896c2899dc4b7aba0d Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 15 May 2024 15:11:00 -0400 Subject: [PATCH 32/37] Remove unused parameters --- src/lisp/kernel/cmp/compile-file-parallel.lisp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/lisp/kernel/cmp/compile-file-parallel.lisp b/src/lisp/kernel/cmp/compile-file-parallel.lisp index 70fde5e923..a58b1b70e5 100644 --- a/src/lisp/kernel/cmp/compile-file-parallel.lisp +++ b/src/lisp/kernel/cmp/compile-file-parallel.lisp @@ -326,7 +326,6 @@ multithreaded performance that we should explore." output-type output-path environment - (optimize t) (optimize-level *optimization-level*) ast-only) "* Arguments @@ -380,8 +379,7 @@ Compile a lisp source file into an LLVM module." (error "Add support for output-type: ~a" output-type)))) (defun compile-stream/parallel (input-stream output-path - &key (optimize t) - (optimize-level *optimization-level*) + &key (optimize-level *optimization-level*) (output-type *default-output-type*) environment ;; Use as little llvm as possible for timing From 6bce0d99878f876c0553aafc69b1909c895cb7d6 Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 15 May 2024 17:47:33 -0400 Subject: [PATCH 33/37] Restore install path debug info for reproducible builds, hopefully --- src/lisp/kernel/clasp-builder.lisp | 9 +++------ src/lisp/kernel/cleavir/debuginfo.lisp | 19 ++++++++++++++++++- 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/lisp/kernel/clasp-builder.lisp b/src/lisp/kernel/clasp-builder.lisp index 1c464a3914..11cd3f8c3c 100644 --- a/src/lisp/kernel/clasp-builder.lisp +++ b/src/lisp/kernel/clasp-builder.lisp @@ -230,14 +230,11 @@ (message :err "About to exit clasp"))) (defun prepare-metadata (system - &aux (make-create-file-args (find-symbol "MAKE-CREATE-FILE-ARGS" "CMP"))) - "Call make-create-file-args with each system path and the installed path so that when the -DIFile is actually created the argument list passed to llvm-sys:create-file will have already -been initialized with install path versus the build path of the source code file." - #+(or) + &aux (setf-translation (fdefinition (list 'setf (find-symbol "DEBUG-PATHNAME-TRANSLATION" "CLASP-CLEAVIR"))))) + "Set up translations for debug info such that we dump the installed paths into DWARF, rather than the build-time logical pathname translation." (mapc #'(lambda (entry &aux (source-path (getf entry :source-path)) (install-path (getf entry :install-path))) - (funcall make-create-file-args source-path (namestring source-path) install-path)) + (funcall setf-translation install-path source-path)) system)) (defun link-modules (output-file all-modules) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index b72faf74b3..22e91c1cf2 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -17,8 +17,25 @@ (defun make-dibuilder (module) (llvm-sys:make-dibuilder module)) +;;; Translate a logical pathname into a physical pathname to put into +;;; the DWARF info. Usually this is just translate-logical-pathname. +;;; But during build, our SYS host will point to the build directory, +;;; whereas we might want debug info to point to the install directory. +;;; For that, we can use (SETF DEBUG-PATHNAME-TRANSLATION) to set up +;;; our own mapping, instead of just using TRANSLATE-LOGICAL-PATHNAME. +;;; See PREPARE-METADATA in clasp-builder.lisp. +;;; We do this instead of having a single parameter like +;;; "*source-debug-physical-pathname*" to COMPILE-FILE as we may need +;;; multiple source files for a given input file due to inlining. +(defvar *debug-pathname-translations* (make-hash-table :test #'equal)) +(defun debug-pathname-translation (pathname) + (or (gethash pathname *debug-pathname-translations*) + (translate-logical-pathname pathname))) +(defun (setf debug-pathname-translation) (physical pathname) + (setf (gethash pathname *debug-pathname-translations*) physical)) + (defun make-difile (pathname) - (let* ((physical (translate-logical-pathname pathname)) + (let* ((physical (debug-pathname-translation pathname)) (source (if (core:logical-pathname-p pathname) (format nil ";; LOGICAL-PATHNAME=~a~%" (namestring pathname)) From 5b40490963a573efd735f24f87af848a67cdf73d Mon Sep 17 00:00:00 2001 From: Bike Date: Thu, 16 May 2024 10:51:35 -0400 Subject: [PATCH 34/37] Output DWARF info for local variables Nothing seems to be showing up, though. Very weird. --- src/lisp/kernel/cleavir/debuginfo.lisp | 30 ++++++++++++++ .../cleavir/translation-environment.lisp | 21 ++++------ src/llvmo/debugInfoExpose.cc | 41 ++++++++++++++++--- 3 files changed, 74 insertions(+), 18 deletions(-) diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index 22e91c1cf2..d797a09ddb 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -279,6 +279,36 @@ (llvm-sys:get-dilocation (cmp:thread-local-llvm-context) lineno column *dbg-current-scope*))) +;;; Generate debug info for a variable binding. +(defun di-bind-variable (name alloca spi vrtype) + (when spi + (multiple-value-bind (path line) (spi-info spi) + (let* ((type (vrtype->di vrtype)) + (var + (llvm-sys:create-auto-variable + *dibuilder* *dbg-current-scope* name + (ensure-difile path) line type nil (di-zeroflags) 0)) + (expr + (llvm-sys:create-expression-none *dibuilder*))) + (llvm-sys:dibuilder/insert-declare + *dibuilder* alloca var expr (get-dilocation spi) + (llvm-sys:get-insert-block cmp:*irbuilder*)))))) + +;;; Generate debug info for an SSA variable binding. +(defun di-bind-value (name value spi vrtype) + (when spi + (multiple-value-bind (path line) (spi-info spi) + (let* ((type (vrtype->di vrtype)) + (var + (llvm-sys:create-auto-variable + *dibuilder* *dbg-current-scope* name + (ensure-difile path) line type nil (di-zeroflags) 0)) + (expr + (llvm-sys:create-expression-none *dibuilder*))) + (llvm-sys:dibuilder/insert-dbg-value-intrinsic + *dibuilder* value var expr (get-dilocation spi) + (llvm-sys:get-insert-block cmp:*irbuilder*)))))) + ;;; if SPI is nil we unset the debug location. (defun set-instruction-source-position (spi) (when *generate-dwarf* diff --git a/src/lisp/kernel/cleavir/translation-environment.lisp b/src/lisp/kernel/cleavir/translation-environment.lisp index 6e4be92268..546575f266 100644 --- a/src/lisp/kernel/cleavir/translation-environment.lisp +++ b/src/lisp/kernel/cleavir/translation-environment.lisp @@ -55,7 +55,8 @@ ;;; a little bit more complete. (defun full-datum-name-as-string (datum) (let ((*package* (find-package "KEYWORD"))) - (write-to-string datum :escape t :readably nil :pretty nil))) + (write-to-string (bir:name datum) + :escape t :readably nil :pretty nil))) (defgeneric vrtype->llvm (vrtype)) (defmethod vrtype->llvm ((vrtype (eql :object))) cmp:%t*%) @@ -79,7 +80,6 @@ ((:local :dynamic) ;; just an alloca (let* ((name (datum-name-as-string var)) - #+(or) (fname (full-datum-name-as-string var)) (rtype (cc-bmir:rtype var))) (if (null rtype) @@ -91,12 +91,8 @@ (first (cc-bmir:rtype var))) (t (error "BUG: Bad rtype ~a" rtype)))) (alloca (cmp:alloca (vrtype->llvm vrtype) 1 name)) - #+(or) - (spi (origin-spi (bir:origin var)))) - ;; set up debug info - ;; Disable for now - FIXME and get it working - #+(or)(cmp:dbg-variable-alloca alloca fname spi) - ;; return + (spi (origin-spi (origin-source (bir:origin var))))) + (di-bind-variable fname alloca spi vrtype) alloca)))) ((:indefinite) ;; make a cell @@ -204,10 +200,11 @@ (check-type variable bir:variable) (if (bir:immutablep variable) (prog1 (setf (gethash variable *datum-values*) value) - ;; FIXME - this doesn't work yet - #+(or)(cmp:dbg-variable-value - value (full-datum-name-as-string variable) - (origin-spi (bir:origin variable)))) + (let ((rtype (cc-bmir:rtype variable))) + (unless (null rtype) + (di-bind-value (full-datum-name-as-string variable) + value (origin-spi (origin-source (bir:origin variable))) + (first rtype))))) (if (null (cc-bmir:rtype variable)) value ;; NOTE: For typed loads in the future, use the rtype diff --git a/src/llvmo/debugInfoExpose.cc b/src/llvmo/debugInfoExpose.cc index 7f22a7d6da..adcc87261f 100644 --- a/src/llvmo/debugInfoExpose.cc +++ b/src/llvmo/debugInfoExpose.cc @@ -333,13 +333,42 @@ CL_LAMBDA(dibuilder scope name argno file lineno type always-preserve-p flags an CL_LISPIFY_NAME(createParameterVariable); CL_EXTERN_DEFMETHOD(DIBuilder_O, &llvm::DIBuilder::createParameterVariable); -// We don't expose the instruction version since we don't really need it. +// We want to use these instead of manually inserting an intrinsic +// call so that when LLVM transitions to debug info records we +// don't have to do anything. +// (Despite the name, insertDbgValueIntrinsic can insert the new +// records rather than an intrinsic.) +// We don't expose the insert-before-instruction versions as we +// do not need them. +// FIXME: Function instead of a method because we don't really +// care about the DbgInstPtr return value and exposing it would +// be rather complex. CL_LAMBDA(dibuilder val varinfo expr dilocation basic-block); -CL_LISPIFY_NAME(insertDbgValueIntrinsic); -CL_EXTERN_DEFMETHOD(DIBuilder_O, (llvm::Instruction * (llvm::DIBuilder::*)(llvm::Value * Val, llvm::DILocalVariable* VarInfo, - llvm::DIExpression* Expr, const llvm::DILocation* DL, - llvm::BasicBlock* InsertAtEnd)) & - llvm::DIBuilder::insertDbgValueIntrinsic); +CL_LISPIFY_NAME(dibuilder/insertDbgValueIntrinsic); +CL_DEFUN void llvm_sys__insert_dbg_value(llvm::DIBuilder& DIBuilder, + llvm::Value* V, + llvm::DILocalVariable* VarInfo, + llvm::DIExpression* Expr, + DILocation_sp DL, + llvm::BasicBlock* InsertAtEnd) +{ + // FIXME: why not just use from_object? + // This is cargo-culted from IRBuilderBase_O::SetCurrentDebugLocation + llvm::DILocation* real_diloc = DL->operator llvm::DILocation*(); + DIBuilder.insertDbgValueIntrinsic(V, VarInfo, Expr, real_diloc, InsertAtEnd); +} +CL_LAMBDA(dibuilder val varinfo expr dilocation basic-block); +CL_LISPIFY_NAME(dibuilder/insertDeclare); +CL_DEFUN void llvm_sys__insert_declare(llvm::DIBuilder& DIBuilder, + llvm::Value* Storage, + llvm::DILocalVariable* VarInfo, + llvm::DIExpression* Expr, + DILocation_sp DL, + llvm::BasicBlock* InsertAtEnd) +{ + llvm::DILocation* real_diloc = DL->operator llvm::DILocation*(); + DIBuilder.insertDeclare(Storage, VarInfo, Expr, real_diloc, InsertAtEnd); +} CL_LAMBDA(dibuilder); CL_LISPIFY_NAME(finalize); From 9d9e41ee0e95c3ef92dd30c041dc1e694dbd4a59 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 17 May 2024 10:34:00 -0400 Subject: [PATCH 35/37] Clean up unused code for source pos infos --- include/clasp/core/sourceFileInfo.fwd.h | 5 -- include/clasp/core/sourceFileInfo.h | 35 +----------- src/analysis/clasp_gc.sif | 6 -- src/analysis/clasp_gc_cando.sif | 6 -- src/core/lambdaListHandler.cc | 2 +- src/core/sourceFileInfo.cc | 76 +------------------------ 6 files changed, 6 insertions(+), 124 deletions(-) diff --git a/include/clasp/core/sourceFileInfo.fwd.h b/include/clasp/core/sourceFileInfo.fwd.h index 427905a905..42b953bb71 100644 --- a/include/clasp/core/sourceFileInfo.fwd.h +++ b/include/clasp/core/sourceFileInfo.fwd.h @@ -29,9 +29,4 @@ THE SOFTWARE. namespace core { FORWARD(FileScope); FORWARD(SourcePosInfo); - -uint clasp_sourcePosInfo_fileHandle(SourcePosInfo_sp info); -size_t clasp_sourcePosInfo_filepos(SourcePosInfo_sp info); -uint clasp_sourcePosInfo_lineno(SourcePosInfo_sp info); -uint clasp_sourcePosInfo_column(SourcePosInfo_sp info); }; // namespace core diff --git a/include/clasp/core/sourceFileInfo.h b/include/clasp/core/sourceFileInfo.h index 7d6eaa7e7e..01fb922f2a 100644 --- a/include/clasp/core/sourceFileInfo.h +++ b/include/clasp/core/sourceFileInfo.h @@ -58,11 +58,8 @@ class FileScope_O : public Scope_O { explicit FileScope_O(); virtual ~FileScope_O(){}; void initialize() override; - GCPRIVATE : // instance variables here - Pathname_sp _pathname; - /*! Allocated buffer that stores the file name until the program exits */ - char* _PermanentPathName; - char* _PermanentFileName; +GCPRIVATE : // instance variables here + Pathname_sp _pathname; int _FileHandle; public: // Functions here @@ -72,8 +69,6 @@ class FileScope_O : public Scope_O { string namestring() const; CL_LISPIFY_NAME("FileScope-pathname"); CL_DEFMETHOD Pathname_sp pathname() const { return this->_pathname; }; - const char* permanentPathName(); - const char* permanentFileName(); string __repr__() const override; }; // FileScope class @@ -133,32 +128,6 @@ SourcePosInfo_sp core__makeSourcePosInfo(const string& filename, bool filenamep, bool linenop, size_t column, bool columnp, T_sp function_scope = nil(), bool function_scope_p = false, T_sp inlined_at = nil(), bool inlined_at_p = false, T_sp defaults = nil(), bool defaults_p = false); - -inline core::Fixnum safe_fileId(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_FileId; -} - -inline core::Fixnum safe_filepos(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_FileId; -} - -inline core::Fixnum safe_lineno(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_Lineno; -} - -inline core::Fixnum safe_column(T_sp spi) { - if (spi.nilp()) - return 0; - return gc::As(spi)->_Column; -} -// Pass all arguments to a FunctionClosure -#define SOURCE_POS_INFO_FIELDS(spi) safe_fileId(spi), safe_filepos(spi), safe_lineno(spi), safe_column(spi) }; // namespace core template <> struct gctools::GCInfo { static bool constexpr NeedsInitialization = false; diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index ed8d823cd6..d3dfaf2cc2 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -4843,12 +4843,6 @@ {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_pathname")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentPathName")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentFileName")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_FileHandle")} {class-kind :stamp-name "STAMPWTAG_core__Path_O" :stamp-key "core::Path_O" diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index cc966ffc63..2b50a2402d 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -9746,12 +9746,6 @@ {fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" :offset-ctype "gctools::smart_ptr" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_pathname")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentPathName")} -{fixed-field :offset-type-cxx-identifier "RAW_POINTER_OFFSET" :offset-ctype "UnknownType" - :offset-base-ctype "core::FileScope_O" - :layout-offset-field-names ("_PermanentFileName")} {fixed-field :offset-type-cxx-identifier "ctype_int" :offset-ctype "int" :offset-base-ctype "core::FileScope_O" :layout-offset-field-names ("_FileHandle")} {class-kind :stamp-name "STAMPWTAG_core__Path_O" :stamp-key "core::Path_O" diff --git a/src/core/lambdaListHandler.cc b/src/core/lambdaListHandler.cc index 672105f9ba..ab344dc246 100644 --- a/src/core/lambdaListHandler.cc +++ b/src/core/lambdaListHandler.cc @@ -905,7 +905,7 @@ List_sp process_macro_lambda_list(List_sp lambda_list) { Symbol_sp name_symbol = cl__gensym(SimpleBaseString_O::make("macro-name")); // SourceCodeList_sp new_name_ll = // SourceCodeCons_O::createWithDuplicateSourceCodeInfo(name_symbol,new_lambda_list,lambda_list,_lisp); - ql::list sclist; // (af_lineNumber(lambda_list),af_column(lambda_list),core__file_scope(lambda_list)); + ql::list sclist; sclist << whole_symbol << environment_symbol << Cons_O::create(name_symbol, new_lambda_list); List_sp macro_ll = sclist.cons(); return macro_ll; diff --git a/src/core/sourceFileInfo.cc b/src/core/sourceFileInfo.cc index 363e05e993..1f766cf38f 100644 --- a/src/core/sourceFileInfo.cc +++ b/src/core/sourceFileInfo.cc @@ -123,8 +123,6 @@ CL_DEFUN Integer_sp core__source_pos_info_filepos(T_sp info) { SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } -uint clasp_sourcePosInfo_lineno(SourcePosInfo_sp info) { return info->_Lineno; } - CL_LAMBDA(source-pos-info); CL_DECLARE(); CL_DOCSTRING(R"dx(sourcePosInfoLineno)dx"); @@ -133,7 +131,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_lineno(T_sp info) { if (info.nilp()) return make_fixnum(0); if (gc::IsA(info)) { - return Integer_O::create((gc::Fixnum)clasp_sourcePosInfo_lineno(gc::As_unsafe(info))); + return Integer_O::create(info.as_unsafe()->_Lineno); } SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } @@ -148,7 +146,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_column(T_sp info) { if (info.nilp()) return make_fixnum(0); if (gc::IsA(info)) { - return make_fixnum(clasp_sourcePosInfo_column(gc::As_unsafe(info))); + return Integer_O::create(info.as_unsafe()->_Column); } SIMPLE_ERROR("Argument {} must be a source-pos-info object", _rep_(info)); } @@ -156,43 +154,7 @@ CL_DEFUN Fixnum_sp core__source_pos_info_column(T_sp info) { namespace core { -#define ARGS_af_lineno "(arg)" -#define DECL_af_lineno "" -#define DOCS_af_lineno "lineNumber" -uint af_lineno(T_sp obj) { - if (obj.nilp()) { - return 0; - } else if (Cons_sp co = obj.asOrNull()) { - IMPLEMENT_MEF(fmt::format("Handle cons {} for af_lineno", _rep_(co))); - } else if (cl__streamp(obj)) { - return stream_input_line_as_uint(obj); - } else if (Function_sp fo = obj.asOrNull()) { - return af_lineno(fo->sourcePosInfo()); - } else if (SourcePosInfo_sp info = obj.asOrNull()) { - return info->_Lineno; - } - SIMPLE_ERROR("Implement lineNumber for {}", _rep_(obj)); -}; - -#define ARGS_af_column "(arg)" -#define DECL_af_column "" -#define DOCS_af_column "column" -uint af_column(T_sp obj) { - if (obj.nilp()) { - return 0; - } else if (gc::IsA(obj)) { - IMPLEMENT_MEF("Handle cons for af_column"); - } else if (cl__streamp(obj)) { - return stream_input_column_as_uint(obj); - } else if (Function_sp fo = obj.asOrNull()) { - return af_column(fo->sourcePosInfo()); - } else if (SourcePosInfo_sp info = obj.asOrNull()) { - return info->_Column; - } - SIMPLE_ERROR("Implement column for {}", _rep_(obj)); -}; - -FileScope_O::FileScope_O() : Base(), _PermanentPathName(NULL), _PermanentFileName(NULL){}; +FileScope_O::FileScope_O() : Base(){}; void FileScope_O::initialize() { this->Base::initialize(); } @@ -249,24 +211,6 @@ string FileScope_O::parentPathName() const { return s->get_std_string(); } -const char* FileScope_O::permanentPathName() { - if (this->_PermanentPathName == NULL) { - string fn = this->namestring(); - this->_PermanentPathName = (char*)malloc(fn.size() + 1); - ::strcpy(this->_PermanentPathName, fn.c_str()); - } - return this->_PermanentPathName; -} - -const char* FileScope_O::permanentFileName() { - if (this->_PermanentFileName == NULL) { - string fn = this->fileName(); - this->_PermanentFileName = (char*)malloc(fn.size() + 1); - ::strcpy(this->_PermanentFileName, fn.c_str()); - } - return this->_PermanentFileName; -} - CL_DOCSTRING( R"dx(Like make-pathname lets you build a source-pos-info object from scratch or by referencing a defaults source-pos-info that provides default information)dx"); CL_LAMBDA(&key (filename "-nofile-" filenamep) (filepos 0 fileposp) (lineno 0 linenop) (column 0 columnp) (function-scope nil function_scope_p) (inlined-at nil inlined_at_p) (defaults nil defaults_p)); @@ -427,18 +371,4 @@ string SourcePosInfo_O::__repr__() const { return ss.str(); } -#if 0 -bool SourcePosInfo_O::equalp(T_sp other) const { - if (!other.generalp()) return false; - if (this == &*other) return true; - if (!gc::IsA(other)) return false; - SourcePosInfo_sp spi_other = gc::As_unsafe(other); - if (this->_FileId != spi_other->_FileId) return false; - if (this->_Filepos != spi_other->_Filepos) return false; - if (this->_Lineno != spi_other->_Lineno) return false; - if (this->_Column != spi_other->_Column) return false; - return true; -} -#endif - }; // namespace core From ad391297f19d3efb7843c5fff02332251a22f482 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 17 May 2024 11:49:08 -0400 Subject: [PATCH 36/37] Define direct pathname reader for SPIs Saves a bunch of code to go through file scopes, which are arguably unnecessary anyway, and definitely an irrelevant implementation detail. --- include/clasp/core/sourceFileInfo.h | 2 ++ src/core/sourceFileInfo.cc | 20 +++++++++++++------- src/lisp/kernel/cleavir/debuginfo.lisp | 12 ++++++------ src/lisp/kernel/cleavir/translate-btb.lisp | 9 ++------- src/lisp/kernel/cleavir/translate.lisp | 4 +--- src/lisp/kernel/clos/generic.lisp | 4 +--- src/lisp/kernel/cmp/cmpir.lisp | 4 +--- src/lisp/kernel/cmp/cmpltv.lisp | 8 ++------ src/lisp/kernel/cmp/compiler-conditions.lisp | 6 ++---- src/lisp/kernel/lsp/debug.lisp | 4 +--- src/lisp/kernel/lsp/source-location.lisp | 10 ++++------ 11 files changed, 35 insertions(+), 48 deletions(-) diff --git a/include/clasp/core/sourceFileInfo.h b/include/clasp/core/sourceFileInfo.h index 01fb922f2a..2b142b5c81 100644 --- a/include/clasp/core/sourceFileInfo.h +++ b/include/clasp/core/sourceFileInfo.h @@ -113,6 +113,8 @@ class SourcePosInfo_O : public General_O { T_sp _FunctionScope; T_sp _InlinedAt; // Function_sp _Expander; + CL_LISPIFY_NAME(SourcePosInfo/pathname) + CL_DEFMETHOD Pathname_sp pathname() const; CL_DEFMETHOD size_t source_file_pos_filepos() const { return this->_Filepos; } CL_DEFMETHOD size_t source_file_pos_lineno() const { return this->_Lineno; } CL_DEFMETHOD size_t source_file_pos_column() const { return this->_Column; } diff --git a/src/core/sourceFileInfo.cc b/src/core/sourceFileInfo.cc index 1f766cf38f..82205f5bf0 100644 --- a/src/core/sourceFileInfo.cc +++ b/src/core/sourceFileInfo.cc @@ -45,6 +45,14 @@ THE SOFTWARE. namespace core { +static FileScope_sp fscope_from_handle(unsigned int handle) { + WITH_READ_LOCK(globals_->_SourceFilesMutex); + if (handle >= _lisp->_Roots._SourceFiles.size()) { + handle = 0; + } + return _lisp->_Roots._SourceFiles[handle]; +} + CL_LAMBDA(name); CL_DECLARE(); CL_DOCSTRING( @@ -62,13 +70,7 @@ CL_DEFUN T_mv core__file_scope(T_sp sourceFile) { } return _lisp->getOrRegisterFileScope(gc::As(ns)->get_std_string()); } else if (sourceFile.fixnump()) { - WITH_READ_LOCK(globals_->_SourceFilesMutex); - Fixnum_sp fnSourceFile(gc::As(sourceFile)); - size_t idx = unbox_fixnum(fnSourceFile); - if (idx >= _lisp->_Roots._SourceFiles.size()) { - idx = 0; - } - return Values(_lisp->_Roots._SourceFiles[idx], fnSourceFile); + return Values(fscope_from_handle(sourceFile.unsafe_fixnum()), sourceFile); } else if (cl__streamp(sourceFile)) { T_sp so = sourceFile; T_sp sfi = clasp_input_source_file_info(so); @@ -84,6 +86,10 @@ CL_DEFUN T_mv core__file_scope(T_sp sourceFile) { namespace core { +Pathname_sp SourcePosInfo_O::pathname() const { + return fscope_from_handle(this->_FileId)->pathname(); +} + uint clasp_sourcePosInfo_fileHandle(SourcePosInfo_sp info) { return info->_FileId; } size_t clasp_sourcePosInfo_filepos(SourcePosInfo_sp info) { return info->_Filepos; } diff --git a/src/lisp/kernel/cleavir/debuginfo.lisp b/src/lisp/kernel/cleavir/debuginfo.lisp index d797a09ddb..c237e98675 100644 --- a/src/lisp/kernel/cleavir/debuginfo.lisp +++ b/src/lisp/kernel/cleavir/debuginfo.lisp @@ -216,9 +216,9 @@ (defun create-di-main-function (ir name &key (linkage-name name)) (let* ((spi (origin-spi (origin-source (bir:origin ir)))) - (path (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi)))) + (path (if spi + (core:source-pos-info/pathname spi) + #p"-unknown-file-")) (difile (ensure-difile path)) (lineno (core:source-pos-info-lineno spi))) (llvm-sys:dibuilder/create-function @@ -250,9 +250,9 @@ (defun create-di-xep (ir name arity &key (linkage-name name)) (let* ((spi (origin-spi (origin-source (bir:origin ir)))) - (path (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi)))) + (path (if spi + (core:source-pos-info/pathname spi) + #p"-unknown-file-")) (difile (ensure-difile path)) (lineno (core:source-pos-info-lineno spi))) (llvm-sys:dibuilder/create-function diff --git a/src/lisp/kernel/cleavir/translate-btb.lisp b/src/lisp/kernel/cleavir/translate-btb.lisp index 2e57fe58ea..4c44328057 100644 --- a/src/lisp/kernel/cleavir/translate-btb.lisp +++ b/src/lisp/kernel/cleavir/translate-btb.lisp @@ -320,10 +320,7 @@ (if bir (let ((origin (bir:origin bir))) (if origin - (namestring - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin)))) + (namestring (core:source-pos-info/pathname origin)) "repl-code")) "repl-code")) @@ -439,9 +436,7 @@ :function-name (cc::get-or-create-lambda-name irfun) :lambda-list (bir:original-lambda-list irfun) :docstring (bir:docstring irfun) - :source-pathname (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + :source-pathname (core:source-pos-info/pathname spi) :lineno (core:source-pos-info-lineno spi) ;; Why 1+? :column (1+ (core:source-pos-info-column spi)) diff --git a/src/lisp/kernel/cleavir/translate.lisp b/src/lisp/kernel/cleavir/translate.lisp index 92440a4dfe..9487b8f9bf 100644 --- a/src/lisp/kernel/cleavir/translate.lisp +++ b/src/lisp/kernel/cleavir/translate.lisp @@ -1871,9 +1871,7 @@ COMPILE-FILE will use the default *clasp-env*." (pathname (let ((origin (origin-source (bir:origin bir)))) (if origin - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle origin))) + (core:source-pos-info/pathname origin) #p"repl-code")))) (cmp::with-module (:module module) (multiple-value-bind (ordered-raw-constants-list constants-table startup-shutdown-id) diff --git a/src/lisp/kernel/clos/generic.lisp b/src/lisp/kernel/clos/generic.lisp index 498b144742..2e4f559ade 100644 --- a/src/lisp/kernel/clos/generic.lisp +++ b/src/lisp/kernel/clos/generic.lisp @@ -214,9 +214,7 @@ Not a valid documentation object ~A" ;; FIXME: Too many fields and the underlying function makes a new SPI. Dumb. (core:set-source-pos-info gfun - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + (core:source-pos-info/pathname spi) (core:source-pos-info-filepos spi) (core:source-pos-info-lineno spi) ;; 1+ copied from cmpir.lisp. Dunno why it's there. diff --git a/src/lisp/kernel/cmp/cmpir.lisp b/src/lisp/kernel/cmp/cmpir.lisp index aa9f3a7666..ec4dfc39fb 100644 --- a/src/lisp/kernel/cmp/cmpir.lisp +++ b/src/lisp/kernel/cmp/cmpir.lisp @@ -191,9 +191,7 @@ local-function - the lcl function that all of the xep functions call." spi) (let ((lineno 0) (column 0) (filepos 0) (source-pathname "-unknown-file-")) (when spi - (setf source-pathname (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi))) + (setf source-pathname (core:source-pos-info/pathname spi) lineno (core:source-pos-info-lineno spi) ;; FIXME: Why 1+? column (1+ (core:source-pos-info-column spi)) diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index 5f7bcc052d..eb8c1f10f6 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -1317,9 +1317,7 @@ (make-instance 'spi-attr :function inst :pathname (ensure-constant - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle cspi)))) + (core:source-pos-info/pathname cspi)) :lineno (core:source-pos-info-lineno cspi) :column (core:source-pos-info-column cspi) :filepos (core:source-pos-info-filepos cspi)))) @@ -1443,9 +1441,7 @@ :start (core:bytecode-debug-info/start item) :end (core:bytecode-debug-info/end item) :pathname (ensure-constant - (core:file-scope-pathname - (core:file-scope - (core:source-pos-info-file-handle spi)))) + (core:source-pos-info/pathname spi)) :lineno (core:source-pos-info-lineno spi) :column (core:source-pos-info-column spi) :filepos (core:source-pos-info-filepos spi)))) diff --git a/src/lisp/kernel/cmp/compiler-conditions.lisp b/src/lisp/kernel/cmp/compiler-conditions.lisp index 0a15ae2886..f8d62a247e 100644 --- a/src/lisp/kernel/cmp/compiler-conditions.lisp +++ b/src/lisp/kernel/cmp/compiler-conditions.lisp @@ -85,8 +85,7 @@ (redefinition-new-type condition) (compiler-warning-name condition) (redefinition-old-type condition) - (file-scope-pathname - (file-scope origin)) + (source-pos-info/pathname origin) (source-pos-info-lineno origin) (source-pos-info-column origin)))))) @@ -279,8 +278,7 @@ Operation was (~s~{ ~s~})." (origin (if (consp origin) (car origin) origin))) (handler-case (format *error-output* "~& at ~a ~d:~d~%" - (file-scope-pathname - (file-scope origin)) + (source-pos-info/pathname origin) (source-pos-info-lineno origin) (source-pos-info-column origin)) (error (e) diff --git a/src/lisp/kernel/lsp/debug.lisp b/src/lisp/kernel/lsp/debug.lisp index 612ac64f6a..71bc0a5f21 100644 --- a/src/lisp/kernel/lsp/debug.lisp +++ b/src/lisp/kernel/lsp/debug.lisp @@ -49,9 +49,7 @@ ;;; these should maybe be deprecated, since they just go through source ;;; position info accessors. -(defun code-source-line-pathname (spi) - (core:file-scope-pathname - (core:file-scope (core:source-pos-info-file-handle spi)))) +(defun code-source-line-pathname (spi) (core:source-pos-info/pathname spi)) (defun code-source-line-line-number (spi) (core:source-pos-info-lineno spi)) (defun code-source-line-column (spi) (core:source-pos-info-column spi)) diff --git a/src/lisp/kernel/lsp/source-location.lisp b/src/lisp/kernel/lsp/source-location.lisp index bb68bb79cc..6f07ba5102 100644 --- a/src/lisp/kernel/lsp/source-location.lisp +++ b/src/lisp/kernel/lsp/source-location.lisp @@ -60,12 +60,10 @@ ;; FIXME: Move this source debug stuff to an interface ;; (in SPI, probably) (defun source-position-info->source-location (source-position-info definer) - (let ((csi (core:file-scope - (core:source-pos-info-file-handle source-position-info)))) - (make-source-location - :pathname (core:file-scope-pathname csi) - :offset (core:source-pos-info-filepos source-position-info) - :definer definer))) + (make-source-location + :pathname (core:source-pos-info/pathname source-position-info) + :offset (core:source-pos-info-filepos source-position-info) + :definer definer)) ;;; Class source positions are just stored in a slot, or ones from C++ are ;;; stored as sysprops. We prefer the slot. From abd44ac16bf031d89a0776f9a384325ff5152081 Mon Sep 17 00:00:00 2001 From: Bike Date: Fri, 17 May 2024 13:46:10 -0400 Subject: [PATCH 37/37] More source pos info cleanup --- include/clasp/core/sourceFileInfo.h | 14 ++--------- src/core/foundation.cc | 14 ----------- src/core/readtable.cc | 39 +++++++++++++---------------- src/core/sourceFileInfo.cc | 19 ++------------ 4 files changed, 21 insertions(+), 65 deletions(-) diff --git a/include/clasp/core/sourceFileInfo.h b/include/clasp/core/sourceFileInfo.h index 2b142b5c81..d74cc20ebf 100644 --- a/include/clasp/core/sourceFileInfo.h +++ b/include/clasp/core/sourceFileInfo.h @@ -26,8 +26,6 @@ THE SOFTWARE. */ /* -^- */ -#define USE_WEAK_HASH_TABLE_FOR_SOURCE_POS_INFO 1 - #include #include #include @@ -64,9 +62,6 @@ GCPRIVATE : // instance variables here public: // Functions here int fileHandle() const { return this->_FileHandle; }; - string fileName() const; - string parentPathName() const; - string namestring() const; CL_LISPIFY_NAME("FileScope-pathname"); CL_DEFMETHOD Pathname_sp pathname() const { return this->_pathname; }; string __repr__() const override; @@ -85,10 +80,10 @@ class SourcePosInfo_O : public General_O { public: // ctor/dtor for classes with shared virtual base explicit SourcePosInfo_O() : _FileId(UNDEF_UINT), _Filepos(0), _Lineno(0), _Column(0), _FunctionScope(nil()), - _InlinedAt(nil()){}; //, _Filepos(0) {}; + _InlinedAt(nil()){}; public: // instance variables here SourcePosInfo_O(uint spf, size_t filepos, uint spln, uint spc, T_sp function_scope, T_sp inlined_at) - : _FileId(spf), _Filepos(filepos), _Lineno(spln), _Column(spc), //, _Expander(expander) {} + : _FileId(spf), _Filepos(filepos), _Lineno(spln), _Column(spc), _FunctionScope(function_scope), _InlinedAt(inlined_at){}; public: @@ -104,7 +99,6 @@ class SourcePosInfo_O : public General_O { int column() const { return this->_Column; }; T_sp function_scope() const { return this->_FunctionScope; }; T_sp inlined_at() const { return this->_InlinedAt; }; - // bool equalp(T_sp obj) const; public: uint _FileId; size_t _Filepos; @@ -112,12 +106,8 @@ class SourcePosInfo_O : public General_O { uint _Column; T_sp _FunctionScope; T_sp _InlinedAt; - // Function_sp _Expander; CL_LISPIFY_NAME(SourcePosInfo/pathname) CL_DEFMETHOD Pathname_sp pathname() const; - CL_DEFMETHOD size_t source_file_pos_filepos() const { return this->_Filepos; } - CL_DEFMETHOD size_t source_file_pos_lineno() const { return this->_Lineno; } - CL_DEFMETHOD size_t source_file_pos_column() const { return this->_Column; } SourcePosInfo_sp source_pos_info_copy() const; T_sp setf_source_pos_info_inlined_at(T_sp inlinedAt); T_sp source_pos_info_inlined_at() const; diff --git a/src/core/foundation.cc b/src/core/foundation.cc index 74c67f197d..48357f1bf4 100644 --- a/src/core/foundation.cc +++ b/src/core/foundation.cc @@ -1260,20 +1260,6 @@ T_sp lisp_createStr(const string& s) { return SimpleBaseString_O::make(s); } T_sp lisp_createFixnum(int fn) { return make_fixnum(fn); } -SourcePosInfo_sp lisp_createSourcePosInfo(const string& fileName, size_t filePos, int lineno) { - SimpleBaseString_sp fn = SimpleBaseString_O::make(fileName); - T_mv sfi_mv = core__file_scope(fn); - MultipleValues& mvn = core::lisp_multipleValues(); - Fixnum_sp handle = gc::As(mvn.valueGet(1, sfi_mv.number_of_values())); - int sfindex = unbox_fixnum(handle); - return SourcePosInfo_O::create(sfindex, filePos, lineno, 0); -} - -/*! Create a core:source-pos-info object on the fly */ -SourcePosInfo_sp core__createSourcePosInfo(const string& filename, size_t filePos, int lineno) { - return lisp_createSourcePosInfo(filename, filePos, lineno); -} - T_sp lisp_createList(T_sp a1) { return Cons_O::create(a1, nil()); } T_sp lisp_createList(T_sp a1, T_sp a2) { return Cons_O::createList(a1, a2); }; T_sp lisp_createList(T_sp a1, T_sp a2, T_sp a3) { return Cons_O::createList(a1, a2, a3); }; diff --git a/src/core/readtable.cc b/src/core/readtable.cc index 2d10475d8e..9efdfd305a 100644 --- a/src/core/readtable.cc +++ b/src/core/readtable.cc @@ -269,18 +269,16 @@ CL_DECLARE(); CL_DOCSTRING(R"dx(Error signaler for when a comma (or splice) is outside a backquote.)dx"); DOCGROUP(clasp); CL_DEFUN T_mv core__reader_error_backquote_context(T_sp sin) { - FileScope_sp info = gc::As(core__file_scope(sin)); - // FIXME: Use a real condition class. - // SIMPLE_ERROR("Comma outside of backquote in file: {} line: {}", info->fileName() , stream_input_line(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in stream at line: ~a column ~a."), - Cons_O::createList(Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in stream: ~a at line: ~a column ~a."), + Cons_O::createList(sin, + Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Comma outside of backquote in file: ~a line: ~a column ~a."), - Cons_O::createList(SimpleBaseString_O::make(fn), + Cons_O::createList(path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); @@ -329,16 +327,16 @@ CL_DECLARE(); CL_DOCSTRING(R"dx(reader_error_unmatched_close_parenthesis)dx"); DOCGROUP(clasp); CL_DEFUN T_mv core__reader_error_unmatched_close_parenthesis(T_sp sin, Character_sp ch) { - FileScope_sp info = gc::As(core__file_scope(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in stream at line: ~a column ~a."), - Cons_O::createList(Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in stream ~a at line: ~a column ~a."), + Cons_O::createList(sin, + Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Unmatched close parenthesis in file ~a line: ~a column ~a."), - Cons_O::createList(SimpleBaseString_O::make(fn), + Cons_O::createList(path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); @@ -405,18 +403,15 @@ CL_DEFUN T_mv core__dispatch_macro_character(T_sp sin, Character_sp ch) { Character_sp subchar = gc::As(cl__read_char(sin, _lisp->_true(), nil(), _lisp->_true())); T_sp macro_func = cl__get_dispatch_macro_character(ch, subchar, _lisp->getCurrentReadTable()); if (macro_func.nilp()) { - // SIMPLE_ERROR("Undefined reader macro for {} {}", _rep_(ch) , _rep_(subchar)); - // Need to be a reader error - FileScope_sp info = gc::As(core__file_scope(sin)); - string fn = info->fileName(); - if (fn.compare("-no-name-") == 0) { - READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in stream at line: ~a column ~a."), - Cons_O::createList(ch, subchar, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), + T_sp path = stream_pathname(sin); + if (path.nilp()) { + READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in stream ~a at line: ~a column ~a."), + Cons_O::createList(ch, subchar, sin, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); } else { READER_ERROR(SimpleBaseString_O::make("Undefined reader macro for char '~a' subchar '~a' in file ~a line: ~a column ~a."), - Cons_O::createList(ch, subchar, SimpleBaseString_O::make(fn), + Cons_O::createList(ch, subchar, path, Cons_O::create(make_fixnum(stream_input_line_as_uint(sin)), nil()), Cons_O::create(make_fixnum(stream_input_column_as_uint(sin)), nil())), sin); diff --git a/src/core/sourceFileInfo.cc b/src/core/sourceFileInfo.cc index 82205f5bf0..4273a83bd5 100644 --- a/src/core/sourceFileInfo.cc +++ b/src/core/sourceFileInfo.cc @@ -75,8 +75,8 @@ CL_DEFUN T_mv core__file_scope(T_sp sourceFile) { T_sp so = sourceFile; T_sp sfi = clasp_input_source_file_info(so); return core__file_scope(sfi); - } else if (FileScope_sp sfi = sourceFile.asOrNull()) { - return _lisp->getOrRegisterFileScope(sfi->namestring()); + } else if (sourceFile.isA()) { + return sourceFile; } else if (SourcePosInfo_sp spi = sourceFile.asOrNull()) { return core__file_scope(make_fixnum(spi->_FileId)); } @@ -202,21 +202,6 @@ string FileScope_O::__repr__() const { return ss.str(); } -string FileScope_O::fileName() const { - String_sp s = gc::As(cl__file_namestring(this->_pathname)); - return s->get_std_string(); -} - -string FileScope_O::namestring() const { - String_sp s = gc::As(cl__namestring(this->_pathname)); - return s->get_std_string(); -} - -string FileScope_O::parentPathName() const { - String_sp s = gc::As(cl__directory_namestring(this->_pathname)); - return s->get_std_string(); -} - CL_DOCSTRING( R"dx(Like make-pathname lets you build a source-pos-info object from scratch or by referencing a defaults source-pos-info that provides default information)dx"); CL_LAMBDA(&key (filename "-nofile-" filenamep) (filepos 0 fileposp) (lineno 0 linenop) (column 0 columnp) (function-scope nil function_scope_p) (inlined-at nil inlined_at_p) (defaults nil defaults_p));