mirrors/janet
1
0
Fork 0
mirror of https://github.com/janet-lang/janet synced 2025-01-22 21:26:51 +00:00
Code Issues 1 Releases Wiki Activity

Work on some local type inference.

Browse Source 
Right to left type inference in expressions for binary operators.
This commit is contained in:
Calvin Rose 2024-09-29 11:37:04 -05:00
parent a588f1f242
commit e96dd512f3
2 changed files with 212 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

366
examples/sysir/frontend.janet
View File

@ -12,13 +12,14 @@
# * tail call returns
# * function definitions
# * arrays (declaration, loads, stores)
# * ...
# insight - using : inside symbols for types can be used to allow manipulating symbols with macros
(defdyn *ret-type* "Current function return type")
(def slot-to-name @[])
(def name-to-slot @{})
(def type-to-name @[])
(def name-to-type @{})
(def slot-types @{})
(defn get-slot
[&opt new-name]
@ -44,6 +45,24 @@
(assert t)
t)
(defn binding-type
[name]
(def slot (assert (get name-to-slot name)))
(assert (get slot-types slot)))
(defn slot-type
[slot]
(assert (get slot-types slot)))
(defn assign-type
[name typ]
(def slot (get name-to-slot name))
(put slot-types slot typ))
(defn assign-slot-type
[slot typ]
(put slot-types slot typ))
(defn setup-default-types
[ctx]
(def into @[])
@ -76,195 +95,215 @@
### Inside functions
###
(defdyn *ret-type* "Return type hint if inside function body")
(defn visit1
"Take in a form and compile code and put it into `into`. Return result slot."
[code into &opt no-return type-hint]
(cond
(def subresult
(cond
# Compile a constant
(string? code) ~(pointer ,code)
(boolean? code) ~(boolean ,code)
(number? code) ~(,(or type-hint 'long) ,code) # TODO - should default to double
# Compile a constant
(string? code) ~(pointer ,code)
(boolean? code) ~(boolean ,code)
(number? code) ~(,(or type-hint 'double) ,code) # TODO - should default to double
# Needed?
(= :core/u64 (type code)) ~(,(or type-hint 'ulong) ,code)
(= :core/s64 (type code)) ~(,(or type-hint 'long) ,code)
# Needed?
(= :core/u64 (type code)) ~(ulong ,code)
(= :core/s64 (type code)) ~(long ,code)
# Binding
(symbol? code)
(named-slot code)
# Binding
(symbol? code)
(named-slot code)
# Compile forms
(and (tuple? code) (= :parens (tuple/type code)))
(do
(assert (> (length code) 0))
(def [op & args] code)
(case op
# Compile forms
(and (tuple? code) (= :parens (tuple/type code)))
(do
(assert (> (length code) 0))
(def [op & args] code)
(case op
# Arithmetic
'+ (do-binop 'add args into type-hint)
'- (do-binop 'subtract args into type-hint)
'* (do-binop 'multiply args into type-hint)
'/ (do-binop 'divide args into type-hint)
'<< (do-binop 'shl args into type-hint)
'>> (do-binop 'shr args into type-hint)
# Arithmetic
'+ (do-binop 'add args into type-hint)
'- (do-binop 'subtract args into type-hint)
'* (do-binop 'multiply args into type-hint)
'/ (do-binop 'divide args into type-hint)
'<< (do-binop 'shl args into type-hint)
'>> (do-binop 'shr args into type-hint)
# Comparison
'= (do-comp 'eq args into)
'not= (do-comp 'neq args into)
'< (do-comp 'lt args into)
'<= (do-comp 'lte args into)
'> (do-comp 'gt args into)
'>= (do-comp 'gte args into)
# Comparison
'= (do-comp 'eq args into)
'not= (do-comp 'neq args into)
'< (do-comp 'lt args into)
'<= (do-comp 'lte args into)
'> (do-comp 'gt args into)
'>= (do-comp 'gte args into)
# Type hinting
'the
(do
(assert (= 2 (length args)))
(def [xtype x] args)
(def result (visit1 x into false xtype))
(if (tuple? result) # constant
(let [[t y] result]
(assertf (= t xtype) "type mismatch, %p doesn't match %p" t xtype)
[xtype y])
(do
(array/push into ~(bind ,result ,xtype))
result)))
# Type hinting
'the
(do
(assert (= 2 (length args)))
(def [xtype x] args)
(def result (visit1 x into false xtype))
(if (tuple? result) # constant
(let [[t y] result]
(assertf (= t xtype) "type mismatch, %p doesn't match %p" t xtype)
[xtype y])
(do
(array/push into ~(bind ,result ,xtype))
result)))
# Named bindings
'def
(do
(assert (= 2 (length args)))
(def [full-name value] args)
(assert (symbol? full-name))
(def [name tp] (type-extract full-name 'int))
(def result (visit1 value into false tp))
(def slot (get-slot name))
(when tp
(array/push into ~(bind ,slot ,tp)))
(array/push into ~(move ,slot ,result))
slot)
# Named bindings
'def
(do
(assert (= 2 (length args)))
(def [full-name value] args)
(assert (symbol? full-name))
(def [name tp] (type-extract full-name 'int))
(def result (visit1 value into false tp))
(def slot (get-slot name))
(assign-type name tp)
(array/push into ~(bind ,slot ,tp))
(array/push into ~(move ,slot ,result))
slot)
# Named variables
'var
(do
(assert (= 2 (length args)))
(def [full-name value] args)
(assert (symbol? full-name))
(def [name tp] (type-extract full-name 'int))
(def result (visit1 value into false tp))
(def slot (get-slot name))
(when tp
(array/push into ~(bind ,slot ,tp)))
(array/push into ~(move ,slot ,result))
slot)
# Named variables
'var
(do
(assert (= 2 (length args)))
(def [full-name value] args)
(assert (symbol? full-name))
(def [name tp] (type-extract full-name 'int))
(def result (visit1 value into false tp))
(def slot (get-slot name))
(assign-type name tp)
(array/push into ~(bind ,slot ,tp))
(array/push into ~(move ,slot ,result))
slot)
# Assignment
'set
(do
(assert (= 2 (length args)))
(def [to x] args)
(def result (visit1 x into false))
(def toslot (named-slot to))
(array/push into ~(move ,toslot ,result))
toslot)
# Assignment
'set
(do
(assert (= 2 (length args)))
(def [to x] args)
(def type-hint (binding-type to))
(def result (visit1 x into false type-hint))
(def toslot (named-slot to))
(array/push into ~(move ,toslot ,result))
toslot)
# Return
'return
(do
(assert (>= 1 (length args)))
(if (empty? args)
(array/push into '(return))
(do
(def [x] args)
(array/push into ~(return ,(visit1 x into false (dyn *ret-type*))))))
nil)
# Return
'return
(do
(assert (>= 1 (length args)))
(if (empty? args)
(array/push into '(return))
(do
(def [x] args)
(array/push into ~(return ,(visit1 x into false (dyn *ret-type*))))))
nil)
# Sequence of operations
'do
(do
(each form (slice args 0 -2) (visit1 form into true))
(visit1 (last args) into false type-hint))
# Sequence of operations
'do
(do
(each form (slice args 0 -2) (visit1 form into true))
(visit1 (last args) into false type-hint))
# While loop
'while
(do
(def lab-test (keyword (gensym)))
(def lab-exit (keyword (gensym)))
(assert (< 1 (length args)))
(def [cnd & body] args)
(array/push into lab-test)
(def condition-slot (visit1 cnd into false 'boolean))
(array/push into ~(branch-not ,condition-slot ,lab-exit))
(each code body
(visit1 code into true))
(array/push into ~(jump ,lab-test))
(array/push into lab-exit)
nil)
# While loop
'while
(do
(def lab-test (keyword (gensym)))
(def lab-exit (keyword (gensym)))
(assert (< 1 (length args)))
(def [cnd & body] args)
(array/push into lab-test)
(def condition-slot (visit1 cnd into false 'boolean))
(array/push into ~(branch-not ,condition-slot ,lab-exit))
(each code body
(visit1 code into true))
(array/push into ~(jump ,lab-test))
(array/push into lab-exit)
nil)
# Branch
'if
(do
(def lab (keyword (gensym)))
(def lab-end (keyword (gensym)))
(assert (< 2 (length args) 4))
(def [cnd tru fal] args)
(def condition-slot (visit1 cnd into false 'boolean))
(def ret (get-slot))
(array/push into ~(bind ,ret ,type-hint))
(array/push into ~(branch ,condition-slot ,lab))
# false path
(array/push into ~(move ,ret ,(visit1 tru into false type-hint)))
(array/push into ~(jump ,lab-end))
(array/push into lab)
# true path
(array/push into ~(move ,ret ,(visit1 fal into false type-hint)))
(array/push into lab-end)
ret)
# Branch
'if
(do
(def lab (keyword (gensym)))
(def lab-end (keyword (gensym)))
(assert (< 2 (length args) 4))
(def [cnd tru fal] args)
(def condition-slot (visit1 cnd into false 'boolean))
(def ret (get-slot))
(array/push into ~(bind ,ret ,type-hint))
(array/push into ~(branch ,condition-slot ,lab))
# false path
(array/push into ~(move ,ret ,(visit1 tru into false type-hint)))
(array/push into ~(jump ,lab-end))
(array/push into lab)
# true path
(array/push into ~(move ,ret ,(visit1 fal into false type-hint)))
(array/push into lab-end)
ret)
# Insert IR
'ir
(do (array/push into ;args) nil)
# Insert IR
'ir
(do
(assert no-return)
(array/push into ;args)
nil)
# Syscall
'syscall
(do
(def slots @[])
(def ret (if no-return nil (get-slot)))
(each arg args
(array/push slots (visit1 arg into)))
(array/push into ~(syscall :default ,ret ,;slots))
ret)
# Syscall
'syscall
(do
(def slots @[])
(def ret (if no-return nil (get-slot)))
(each arg args
(array/push slots (visit1 arg into)))
(array/push into ~(syscall :default ,ret ,;slots))
ret)
# Assume function call
(do
(def slots @[])
(def ret (if no-return nil (get-slot)))
(each arg args
(array/push slots (visit1 arg into)))
(array/push into ~(call :default ,ret [pointer ,op] ,;slots))
ret)))
# Assume function call
(do
(def slots @[])
(def ret (if no-return nil (get-slot)))
(each arg args
(array/push slots (visit1 arg into)))
(array/push into ~(call :default ,ret [pointer ,op] ,;slots))
ret)))
(errorf "cannot compile %q" code)))
(errorf "cannot compile %q" code)))
# Check type-hint matches return type
(if type-hint
(when-let [t (first subresult)] # TODO - Disallow empty types
(assert (= type-hint t) (string/format "%j, expected type %v, got %v" code type-hint t))))
subresult)
(varfn do-binop
"Emit an operation such as (+ x y).
Extended to support any number of arguments such as (+ x y z ...)"
[opcode args into type-hint]
(var typ type-hint)
(var final nil)
(def slots @[])
(each arg args
(def right (visit1 arg into false type-hint))
(def right (visit1 arg into false typ))
(when (number? right) (array/push slots right))
# If we don't have a type hint, infer types from bottom up
(when (nil? typ)
(when-let [new-typ (get slot-types right)]
(set typ new-typ)))
(set final
(if final
(let [result (get-slot)]
# TODO - finish type inference - we should be able to omit the bind
# call and sysir should be able to infer the type
(array/push into ~(bind ,result int)) # Why int?
(array/push slots result)
(array/push into ~(,opcode ,result ,final ,right))
result)
right)))
(assert typ (string "unable to infer type for %j" [opcode ;args]))
(each slot (distinct slots)
(array/push into ~(bind ,slot ,typ)))
(assert final))
(varfn do-comp
@ -278,8 +317,13 @@
(array/push into ~(bind ,temp-result boolean)))
(var left nil)
(var first-compare true)
(var typ nil)
(each arg args
(def right (visit1 arg into))
(def right (visit1 arg into false typ))
# If we don't have a type hint, infer types from bottom up
(when (nil? typ)
(when-let [new-typ (get slot-types right)]
(set typ new-typ)))
(when left
(if first-compare
(array/push into ~(,opcode ,result ,left ,right))
@ -306,6 +350,7 @@
(do
# TODO doc strings
(table/clear name-to-slot)
(table/clear slot-types)
(array/clear slot-to-name)
(def [name args & body] rest)
(assert (tuple? args))
@ -317,11 +362,12 @@
(each arg args
(def [name tp] (type-extract arg 'int))
(def slot (get-slot name))
(assign-type name tp)
(array/push ir-asm ~(bind ,slot ,tp)))
(with-dyns [*ret-type* fn-tp]
(each part body
(visit1 part ir-asm true)))
# (eprintf "%.99M" ir-asm)
(eprintf "%.99M" ir-asm)
(sysir/asm ctx ir-asm))
(errorf "unknown form %v" form)))
@ -348,7 +394,7 @@
(defn dumpx64-windows
[]
(print (sysir/to-x64 ctx @"" :windows)))
(defn dumpc
[]
(print (sysir/to-c ctx)))

12
examples/sysir/samples.janet
View File

@ -2,7 +2,7 @@
(def square
'(defn square:int [num:int]
(return (* num num))))
(return (* 1 num num))))
(def simple
'(defn simple:int [x:int]
@ -13,10 +13,10 @@
'(defn myprog:int []
(def xyz:int (+ 1 2 3))
(def abc:int (* 4 5 6))
(def x:boolean (= (the int 5) xyz))
(def x:boolean (= xyz 5))
(var i:int 0)
(while (< i (the int 10))
(set i (the int (+ 1 i)))
(while (< i 10)
(set i (+ 1 i))
(printf "i = %d\n" i))
(printf "hello, world!\n%d\n" (the int (if x abc xyz)))
#(return (* abc xyz))))
@ -46,5 +46,5 @@
(compile1 doloop)
(compile1 main-fn)
#(dump)
#(dumpc)
(dumpx64)
(dumpc)
#(dumpx64)