llvm-bitcode-reader.lisp.bkup

;;;; llvm-bitcode-reader.lisp

(in-package #:llvm-bitcode)

(quasiquote-2.0:enable-quasiquote-2.0)
(cl-interpol:enable-interpol-syntax)

;; TODO : somehow I should restrict only to LLVM IR namespace

;; OK, let's first just copy all the enums we have in the LLVMBitCodes.h
;; and then see, how to write it in a more convenient form.

;; TODO : this one should start from FIRST-APPLICATION-BLOCK-ID
(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-enum block-ids
      (module first-application-block-id) paramattr paramattr-group constants function
      identification value-symtab metadata metadata-attachment
      type use-list module-strtab function-summary operand-bundle-tags
      metadata-kind))

;; TODO : these all are 1-based
(defparameter identification-codes '(string epoch))
(defparameter module-codes '(version triple datalayout asm section-name
			     deplib global-var function alias
			     purge-vals gcname))
(defparameter attribute-groups '(entry-old entry grp-entry))
(defparameter type-codes '(numentry void float double label opaque
			   integer pointer function-old half array vector
			   x86-fp80 fp128 ppc-fp128 metadata x86-mmx
			   struct-anon struct-name struct-named
			   function))
(defparameter type-symtab-codes '(entry))
(defparameter value-symtab-codes '(entry bb-entry))
(defparameter metadata-codes '(string _ _ name _ kind _
			       node fn-node named-node attachment))
(defparameter constant-codes '(set-type null undef integer wide-integer
			       float aggregate string cstring ce-binop
			       ce-cast ce-gep ce-select ce-extractelt
			       ce-insertelt ce-shufflevec ce-cmp
			       inline-asm-old
			       ce-shufvec-ex ce-inbounds-gep
			       block-address data inline-asm))

;; TODO : these are 0-based
(defparameter cast-opcodes '(trunc zext sext fp-to-ui fp-to-si ui-to-fp si-to-fp
			     fp-trunc fp-ext ptr-to-int int-to-ptr bit-cast))
(defparameter binary-opcodes '(add sub mul udiv sdiv urem srem shl lshr ashr
			       and or xor))
(defparameter rmw-operations '(xchg add sub and nand or xor max min umax umin))
(defparameter overflowing-flags '(no-unsigned-wrap no-signed-wrap))
(defparameter possibly-extract-flags '(extract))
(defparameter atomic-ordering-codes '(nonatomic unordered monotonic acquire
				      release acqrel seqcst))
(defparameter atomic-synch-scope-codes '(single-thread cross-thread))

;; TODO : these are 1-based
(defparameter function-codes '(declare-blocks binop cast gep select
			       extractelt insertelt shufflevec cmp
			       ret br switch invoke
			       _
			       unreachable phi
			       _ _
			       alloca load
			       _ _
			       vaarg store
			       _
			       extractval insertval cmp2
			       vselect inbounds-gep indirect-br
			       _
			       debug-loc-again call debug-loc fence cmpxchg
			       atomic-rmw resume landing-pad load-atomic store-atomic))
(defparameter uselist-codes '(entry))

;; (defun string<- (lst)
;;   (coerce (mapcar #'char-code lst) 'string))

;; (define-record version 1)
;; (define-record triple 2 string)
;; (define-record data-layout 3 string)
;; (define-record asm 4
;;   (cl-ppcre:split "\\n" (string<- x)))
;; ;; TODO : exactly one section-name per something???
;; (define-record section-name 5 string)
;; (define-record deplib 6 string) ; I've no clue what this is...

;; (define-record global-var 7
;;   ;; complicated definition
;;   ...)

;; (define-record function 8
;;   ;; compicated definition
;;   ...)

;; (define-record alias 9
;;   ;; complicated definition
;;   ...)

;; ;; TODO : after this level of parsing, there is another one, which
;; ;;      : actually uses these PURGE-VALS (and other context-altering things)
;; (define-record purge-vals 10)
;; (define-record gc-name 11 string)


;; (define-block param-attr 9
;;   (records entry))

;; Blocks to write (symbolic) parsers for
;; * (done, module auxfunctions) module
;; * (done, modulo macros) paramattr
;; * (done, modulo macros) paramattr-group
;; * constants
;; * function
;; * (done) identification
;; * value-symtab
;; * metadata
;; * metadata-attachment
;; * type
;; * use-list
;; * module-strtab
;; * function-summary
;; * operand-bundle-tags
;; * metadata-kind

;; TODO : in the actual C++ LLVM code they put a lot of efforts to be able
;;      : to read parts of Bitcode file, to skip over chunks of it efficiently
;;      : and so on. Later, perhaps, this should be implemented too?

;; I should have an enclosing context, where all the block numbers are defined together


(defun parse-raw-attrs (x)
  (let ((attrs1 (funcall (lambda-enum-power-parser
			  0 (z-ext s-ext no-return in-reg struct-ret no-unwind no-alias by-val next read-none
				   read-only no-inline always-inline optimize-for-size stack-protect
				   stack-protect-req))
			 x))
	(attrs2 (funcall (lambda-enum-power-parser
			  21 (no-capture no-red-zone no-implicit-float naked inline-hint))
			 x))
	(attrs3 (funcall (lambda-enum-power-parser
			  29 (returns-twice uw-table non-lazy-bind sanitize-address min-size
					    no-duplicate stack-protect-strong sanitize-thread
					    sanitize-memory no-builtin returned cold builtin
					    optimize-none in-alloca non-null jump-table
					    convergent safe-stack no-recurse inaccessible-mem-only
					    inaccessible-mem-or-arg-mem-only))
			 x)))
    (let ((pre-alignment (int<- (rshift (bit-and (bits<- (lshift (bits<- 31) 16) 64) x) 16)))
	  (pre-stack-alignment (int<- (rshift (bit-and (bits<- (lshift (bits<- 7) 26) 64) x) 26))))
      (let ((res (nconc attrs1 attrs2 attrs3)))
	(when (not (zerop pre-alignment))
	  (push (cons 'alignment (expt 2 (1- pre-alignment)))
		res))
	(when (not (zerop pre-stack-alignment))
	  (push (cons 'stack-alignment (expt 2 (1- pre-stack-alignment)))
		res))
	res))))

(defun decode-llvm-attrs-old (x)
  "The (apparently) legacy way to store parameter attributes."
  (let ((x (bits<- x 64)))
    (let ((alignment (int<- (rshift (bit-and (bits<- (lshift (bits<- "ffff") 16) 64) x) 16))))
      (let ((rest (parse-raw-attrs (bit-ior (bits<- (rshift (bit-and (bits<- (lshift (bits<- "fffff") 32) 64)
								     x)
							    11)
						    64)
					    (bit-and (bits<- "ffff" 64) x)))))
	(if (not (zerop alignment))
	    (cons (cons 'alignment alignment)
		  rest)
	    rest)))))

(defun parse-attrs-old (lst)
  (iter (generate elt in lst)
	(collect (list (next elt)
		       (decode-llvm-attrs-old (next elt))))))
	  
(defun %parse-alias (x &optional (old-p t))
  (let ((it (mk-iter x)))
    (macrolet ((next! () `(inext-or-error it)))
      (let* ((type (type-by-id (next!)))
	     (addr-space (if old-p
			     ;; this is a really kludgy code
			     (let ((it (get-addr-space type)))
			       (setf type (get-element-type type))
			       it)
			     (next!)))
	     (val (next!))
	     (linkage (decode-linkage (next!)))
	     (res `((:type . ,type) (:addr-space . ,addr-space) (:val . ,val) (:linkage . ,linkage))))
	;; now here is the part with optional arguments (the new alias style)
	(handler-case (progn (let ((visibility (decode-visibility (next!))))
			       (if (and (eq 'local (cdr (assoc :linkage res)))
					(not (eq 'default visibility)))
				   (llvm-read-error "Alias with local linkage should have default visibility, ~
                                                     but got ~a" visibility))
			       (push (cons :version version) res))
			     (handler-case (push (cons :dll-storage-class (decode-dll-storage-class (next!))) res)
			       (stop-iteration () (progn (upgrade-dll-import-export-linkage res)
							 (error 'stop-iteration))))
			     (push (cons :thread-local-mode (decode-thread-local (next!))) res)
			     (push (cons :unnamed-addr (next!)) res))
	  (stop-iteration () nil))
	(push res value-list)
	(push (cons res (cdr (assoc :val res))) alias-inits)
	res))))
      
(defun parse-alias (x)
  (%parse-alias x))
(defun parse-alias-old (x)
  (%parse-alias x t))

(defun parse-function (x)
  (destructuring-bind (type call-conv is-proto raw-linkage attributes alignment
			    section visibility
			    &optional gc-id unnamed-addr prologue-id dll-storage
			    comdat prefix personality) x
    (let (linkage)
      (setf type (get-type-by-id type))
      ;; TODO : this dynamic cast to pointer type I don't understand
      ...)))
			   
		   

;; TODO : I've no clue 
;; ;; It was :SKIP for original LLVM, but I guess it's not right -- malformation will go unnoticed
;; (define-block metadata-kind (:on-undefined-blocks :skip :on-undefined-records :warn)
;;   (records (string string)
;; 	   (epoch int)))