Skip to content


Subversion checkout URL

You can clone with
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: bitlisp/bitlisp
base: 01f8e6dbb9
head fork: bitlisp/bitlisp
compare: 2c36101d04
  • 6 commits
  • 5 files changed
  • 0 commit comments
  • 1 contributor
19 src/codegen.lisp
@@ -56,17 +56,14 @@
"main is of inappropriate type ~A (should be ~A)"
(value-type internal-main) ftype)
- (llvm:with-objects ((builder builder))
- (let* ((main (llvm:add-function llvm-module "main" (llvm ftype)))
- (entry (llvm:append-basic-block main "entry"))
- (params (llvm:params main)))
- (setf (llvm:value-name (first params)) "argc"
- (llvm:value-name (second params)) "argv")
- (llvm:position-builder-at-end builder entry)
- (let ((call (llvm:build-call builder (llvm internal-main) (llvm:params main)
- "")))
- (setf (llvm:instruction-calling-convention call) :fast)
- (llvm:build-ret builder call))))))
+ (with-func (main builder llvm-module (llvm ftype)
+ :name "main"
+ :arg-names '("argc" "argv")
+ :calling-convention :c)
+ (let ((call (llvm:build-call builder (llvm internal-main) (llvm:params main)
+ "")))
+ (setf (llvm:instruction-calling-convention call) :fast)
+ (llvm:build-ret builder call)))))
(defun codegen (llvm-module builder form)
(if (null form) nil
65 src/primitives.lisp
@@ -80,20 +80,12 @@
:name ,symbol
:value-type ,type)))
(push (cons ,value (lambda (,bl-module ,module)
- (prog1-let (,func (llvm:add-function module
- (symbol-fqn ,bl-module
- (make-bl-symbol ,name))
- (llvm ,type)))
- (setf (llvm:function-calling-convention ,func) :fast)
- (mapc #'(setf llvm:value-name)
- ',(mapcar (compose #'string-downcase #'first) args)
- (llvm:params ,func))
- (llvm:with-object (,builder builder)
- (llvm:position-builder-at-end builder
- (llvm:append-basic-block ,func "entry"))
- (destructuring-bind ,(mapcar #'first args)
- (llvm:params ,func)
- ,@llvm)))))
+ (with-func (,func ,builder ,module ,type
+ :name (symbol-fqn ,bl-module ,symbol)
+ :arg-names ',(mapcar (compose #'string-downcase #'first) args))
+ (destructuring-bind ,(mapcar #'first args)
+ (llvm:params ,func)
+ ,@llvm))))
(bind *primitives-env* :value ,symbol ,value))))
@@ -130,12 +122,17 @@
:env *primitives-env*
:name ,sym
- (lambda (,inst-type ,module)
- (prog1-let (,func (llvm:add-function ,module (concatenate 'string (module-fqn nil) (string +module-separator+) ,name ":" (princ-to-string ,type)) (llvm ,inst-type)))
- (llvm:with-object (,builder builder)
- (llvm:position-builder-at-end ,builder (llvm:append-basic-block ,func "entry"))
- (destructuring-bind ,(mapcar #'first args) (llvm:params ,func)
- ,@instantiator)))))))))
+ (destructuring-bind ,vars ,qvars
+ (declare (ignorable ,@vars))
+ (lambda (,inst-type ,module)
+ (with-func (,func ,builder ,module ,inst-type
+ :name (concatenate 'string
+ (symbol-fqn nil ,sym)
+ ":"
+ (princ-to-string ,inst-type))
+ :linkage :link-once-odr)
+ (destructuring-bind ,(mapcar #'first args) (llvm:params ,func)
+ ,@instantiator)))))))))
(defprimpoly "int+" (a) `("int" ,a) ((x `("int" ,a)) (y `("int" ,a))) (builder)
(llvm:build-ret (llvm:build-add builder x y "sum")))
@@ -167,15 +164,24 @@
(defprimpoly "uint-rem" (a) `("uint" ,a) ((x `("uint" ,a)) (y `("uint" ,a))) (builder)
(llvm:build-ret (llvm:build-u-rem builder x y "remainder")))
-(defmacro deficmps (types &rest ops)
+(defmacro deficmps (type &rest ops)
(cons 'progn
- (loop :for type :in types :nconc
- (loop :for op :in ops :collect
- `(defprimpoly ,(concatenate 'string (string-downcase type) (string op))
- (a) "bool" ((lhs `(,,type ,a)) (rhs `(,,type ,a))) (builder)
- (llvm:build-ret builder (llvm:build-i-cmp builder ,op lhs rhs "")))))))
-(deficmps ("int" "uint") :> :< := :/= :>= :<=)
+ (loop :for op :in ops :collect
+ `(defprimpoly ,(concatenate 'string (string-downcase type)
+ (if (consp op)
+ (second op)
+ (string op)))
+ (a) "bool" ((lhs `(,,type ,a)) (rhs `(,,type ,a))) (builder)
+ (llvm:build-ret builder (llvm:build-i-cmp builder
+ ,(if (consp op)
+ (first op)
+ op)
+ lhs rhs ""))))))
+(deficmps "int" :> :< := :/= :>= :<=)
+(deficmps "uint" (:unsigned-> ">") (:unsigned-< "<")
+ := :/=
+ (:unsigned->= ">=") (:unsigned-<= "<="))
(defprimpoly "load" (a) a ((pointer `("ptr" ,a))) (builder)
(llvm:build-ret builder (llvm:build-load builder pointer "value")))
@@ -186,3 +192,6 @@
(defprimpoly "vector-elt" (ty size) ty ((vector `("vector" ,ty ,size)) (index '("int" 32))) (builder)
;; TODO: Optional bounds checking
(llvm:build-extract-element builder vector index ""))
+(defprimpoly "bitcast" (a b) b ((x a)) (builder)
+ (llvm:build-bit-cast builder x (llvm b) ""))
35 src/specials.lisp
@@ -55,18 +55,12 @@
(module builder type
(declare (ignore builder))
- (prog1-let (func (llvm:add-function module "function" (llvm type)))
- (setf (llvm:linkage func) :internal
- (llvm:function-calling-convention func) :fast)
- (mapc (lambda (param var) (setf (llvm var) param
- (llvm:value-name param) (name (name var))))
- (llvm:params func) args)
- (llvm:with-object (local-builder builder)
- (llvm:position-builder-at-end local-builder
- (llvm:append-basic-block func "entry"))
- (loop :for (form . rest) :on body
- :for genned := (codegen module local-builder form)
- :unless rest :do (llvm:build-ret local-builder genned))))))
+ (with-func (func local-builder module type
+ :arg-names (mapcar (compose #'name #'name) args))
+ (mapc #'(setf llvm) (llvm:params func) args)
+ (loop :for (form . rest) :on body
+ :for genned := (codegen module local-builder form)
+ :unless rest :do (llvm:build-ret local-builder genned)))))
(defspecial "if" self (condition then else)
@@ -303,15 +297,14 @@
(declare (ignore builder return-type))
(if args
;; Function
- (let* ((cfunc (llvm:add-function module (name (name name)) (llvm ctype)))
- (blfunc (llvm:add-function module (var-fqn name) (llvm ctype)))
- (entry (llvm:append-basic-block blfunc "entry")))
- (llvm:add-function-attributes blfunc :inline-hint)
- (setf (llvm:function-calling-convention blfunc) :fast
- (llvm name) blfunc)
- (llvm:with-object (builder builder)
- (llvm:position-builder-at-end builder entry)
- (llvm:build-ret builder (llvm:build-call builder cfunc (llvm:params blfunc) ""))))
+ (let ((cfunc (llvm:add-function module (name (name name))
+ (llvm ctype))))
+ (with-func (blfunc inner-builder module ctype
+ :attributes '(:inline-hint))
+ (setf (llvm name) blfunc)
+ (llvm:build-ret inner-builder
+ (llvm:build-call inner-builder
+ cfunc (llvm:params blfunc) ""))))
;; Variable
(llvm:add-global module (llvm ctype) (name (name name))))))
7 src/types.lisp
@@ -180,8 +180,11 @@
(defun type-resolve (code &optional (env *primitives-env*))
(etypecase code
(integer code)
- ((or bl-symbol string) (or (lookup code :type env)
- (error "~A names no type binding!" code)))
+ ((or bl-symbol string) (multiple-value-bind (type exists)
+ (lookup code :type env)
+ (if exists
+ type
+ (error "Type ~A is not in scope!" code))))
(list (let ((ctor (type-resolve (first code) env)))
(typecase ctor
(special-tycon (apply (special-tycon-resolver ctor)
18 src/utils.lisp
@@ -23,3 +23,21 @@
(push item matches)
(push item failures))
:finally (return (values matches failures))))
+(defun build-func (module type &key (name "function") arg-names (linkage :internal) (calling-convention :fast) attributes)
+ (let ((func (llvm:add-function module name (llvm type))))
+ (setf (llvm:function-calling-convention func) calling-convention)
+ (setf (llvm:linkage func) linkage)
+ (when attributes
+ (apply #'llvm:add-function-attributes func attributes))
+ (mapc #'(setf llvm:value-name) arg-names (llvm:params func))))
+(defmacro with-func ((func-var builder-var module type &rest keys &key (name "function") arg-names (linkage :internal) (calling-convention :fast) attributes) &body body)
+ "Executes BODY with FUNC-VAR bound to a new function of type TYPE and BUILDER-VAR bound to a new instruction builder positioned at the end of its entry block. Returns the function handle."
+ (declare (ignore name arg-names linkage calling-convention attributes))
+ `(llvm:with-object (,builder-var builder)
+ (let ((,func-var (build-func ,module ,type ,@keys)))
+ (llvm:position-builder-at-end ,builder-var
+ (llvm:append-basic-block ,func-var "entry"))
+ ,@body
+ ,func-var)))

No commit comments for this range

Something went wrong with that request. Please try again.