├── COPYING ├── Makefile ├── backend ├── alt.hl ├── ast.hl ├── backend.hl ├── ir2remove-phi.hl ├── ir2ssa.hl ├── ll-ast.hl ├── ll-inline.hl ├── ll-opt-back.hl ├── ll-opt-model.hl ├── ll-opt-there.hl ├── ll-opt.hl ├── ll-typing.hl ├── passmgr.hl ├── refine.hl ├── ssa-ast.hl └── ssa-fold-ast.hl ├── clike ├── apitst.cs ├── clike-api.hl ├── clike-ast.hl ├── clike-cc-standalone.hl ├── clike-cc.hl ├── clike-compiler-top.hl ├── clike-compiler.hl ├── clike-embed.hl ├── clike-env.hl ├── clike-expand.hl ├── clike-lib.hl ├── clike-llvm.hl ├── clike-parser-utils.hl ├── clike-parser.hl ├── clike-standalone.hl ├── clike-types-utils.hl ├── clike-types.hl ├── clike-utils.hl └── clike.hl ├── doc ├── doc.pdf ├── doc.tex └── doc_backend.tex ├── llvm-wrapper ├── Makefile ├── bindings │ ├── lib.hl │ ├── llvm-ast.hl │ ├── llvm-emit.hl │ └── llvm.hl ├── llvm-bindings-list.al ├── llvm-bindings-lst-3.9.0svn.al ├── llvm-lib.cpp ├── llvm-stub.h ├── llvm-wrapper-base.h ├── native │ └── marshal.hl ├── natnet2.c ├── rebuild.py └── tools │ ├── emit-cpp.hl │ ├── emit-header.hl │ └── emit-mbase.hl ├── lvmkey.snk ├── readme.md ├── tests ├── syntax.c ├── syntax.ref ├── templates.c ├── tests.c ├── tests.ref └── typeof.c └── tools ├── decltype.h └── templates.h /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Meta Alternative Ltd. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PFRONT := pfront 2 | MONO := mono 3 | LLI := lli 4 | PWD = $(shell pwd) 5 | 6 | all: clikecc.exe clikescc.exe doc/doc.pdf 7 | 8 | llvm-wrapper/lib/LLVM.so: 9 | $(MAKE) -C llvm-wrapper 10 | 11 | -include MBaseLLVM.dll.d 12 | MBaseLLVM.dll: llvm-wrapper/lib/LLVM.so 13 | $(PFRONT) /d MBaseLLVM ./llvm-wrapper/bindings/lib.hl 14 | cp MBaseLLVM.dll clike/ 15 | 16 | -include CLikeCore.dll.d 17 | CLikeCore.dll: MBaseLLVM.dll 18 | $(PFRONT) /d CLikeCore ./clike/clike-lib.hl 19 | cp CLikeCore.dll clike/ 20 | 21 | -include CLikeSCore.dll.d 22 | CLikeSCore.dll: 23 | $(PFRONT) /d CLikeSCore ./clike/clike-standalone.hl 24 | cp CLikeSCore.dll clike/ 25 | 26 | -include clikecc.exe.d 27 | clikecc.exe: CLikeCore.dll 28 | $(PFRONT) /c clikecc ./clike/clike-cc.hl 29 | 30 | -include clikescc.exe.d 31 | clikescc.exe: CLikeSCore.dll 32 | $(PFRONT) /c clikescc ./clike/clike-cc-standalone.hl 33 | 34 | doc/doc.pdf: clikescc.exe 35 | dot -Tps doc/clike.dot > doc/clike.eps 36 | epstopdf doc/clike.eps -o doc/clike.pdf 37 | cd doc; pdflatex doc.tex 38 | cd doc; pdflatex doc.tex 39 | 40 | test: clikecc.exe 41 | LD_LIBRARY_PATH=$(PWD)/llvm-wrapper/lib/:$(LD_LIBRARY_PATH) $(MONO) clikecc.exe tests/tests.c > tests/tests.out 42 | diff tests/tests.out tests/tests.ref 43 | LD_LIBRARY_PATH=$(PWD)/llvm-wrapper/lib/:$(LD_LIBRARY_PATH) $(MONO) clikecc.exe /out syntax tests/syntax.c 44 | $(LLI) syntax.o > tests/syntax.out 45 | diff tests/syntax.out tests/syntax.ref 46 | -------------------------------------------------------------------------------- /backend/alt.hl: -------------------------------------------------------------------------------- 1 | // An alternative backend 2 | 3 | include "./ast.hl" 4 | include "./refine.hl" 5 | 6 | include "./backend.hl" 7 | 8 | define ir2backend_hook = mkref([]) 9 | 10 | function ir2backend(mdl, fnm, oldmdl) 11 | { 12 | h = deref(ir2backend_hook); 13 | if(h) h(mdl,fnm, oldmdl) else mdl 14 | } -------------------------------------------------------------------------------- /backend/ast.hl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | AST is based on: 4 | http://llvm.org/docs/LangRef.html 5 | 6 | */ 7 | 8 | 9 | ast ir0 { 10 | 11 | irstructel is (irtype:t, irval:v); 12 | 13 | irtoplevel = 14 | %function(*ircallconv:cc, ident:name, irtype:ret, bool:va, *irarg:args, *irbblock:body, .*any:annotations) 15 | | eglobal(ident:name, irtype:type) 16 | | global(ident:name, irtype:type, irval:v) // v = const only! 17 | | comment(anything:x) 18 | ; 19 | 20 | ircode is (*irstmt:code); 21 | irbblock is (ident:name, .*irstmt:code); 22 | irarg is (irtype:type, ident:name); 23 | irlabel is (ident:nm); 24 | 25 | irval = 26 | false() 27 | | true() 28 | | null(irtype:t) 29 | | integer(int:v, .*ident:itp) 30 | | float(float:v, .*ident:ftp) 31 | | struct(. *irstructel:elts) 32 | | array(irtype:t, . *irval:elts) 33 | | vector(. *irval:elts) 34 | | zero(irtype:t) 35 | | undef(irtype:t) 36 | | blockaddress(ident:fn, ident:blk) 37 | | var(ident:nm) 38 | | global(ident:nm) 39 | | globalfun(ident:nm) 40 | | sizeof(irtype:t) 41 | ; 42 | 43 | irtype = 44 | integer(ident:type) 45 | | float(ident:ftype) 46 | | label() 47 | | void() 48 | | array(*int:dims, irtype:t, .*aspace:spc) 49 | | %function(irtype:ret, .*irtype:args) 50 | | varfunction(irtype:ret, .*irtype:args) 51 | | struct(ident:nm, . *irtype:elts) 52 | | structref(ident:nm) 53 | | packed(ident:nm, . *irtype:elts) 54 | | pointer(irtype:t,.*aspace:spc) 55 | | vector(int:n, irtype:t) 56 | | alias(ident:id) 57 | ; 58 | 59 | irstmt = /* More or less the same as terminal instructions, 60 | with 'store' moved here and 'invoke' moved to irexpr */ 61 | set(ident:nm, irexpr:e) 62 | | setstring(ident:nm, string:s) 63 | | ret(irval:value) 64 | | vret() 65 | | br(irval:cnd, irlabel:tr, irlabel:fl) 66 | | br_label(ident:nm) 67 | | switch(irval:value, irlabel:els, *irswitchdst:cases) 68 | | indirectbr(irsometype:t, irval:addr, *irlabel:ds) 69 | /* No invoke here, since it returns a value */ 70 | | unwind() 71 | | unreacheable() 72 | /* 'store' is a memory instruction, but it does not return any value */ 73 | | store(irval:ptr, irval:e) 74 | | volatile_store(irtype:t, irval:value, irtype:ty, irval:ptr, *irval:align) 75 | | label(ident:nm) 76 | 77 | ; 78 | 79 | irswitchdst is ( irval:value, irlabel:dst ); 80 | irphi is (irval:value, irlabel:dst); 81 | 82 | irexpr = 83 | binary(irbinop:op, irval:l, irval:r) 84 | | extractelement(int:n, irval:v, irval:idx) 85 | | insertelement(int:n, irtype:t, irval:v, irval:elt, irval:idx) 86 | | shufflevector(int:n1, irval:val1, int:n1, irval:val2, irval:mask) 87 | | extractvalue(iraggtype:t, irval:v, irval:idx) 88 | | insertvalue(irval:v, irtype:tv, irval:elt, irval:idx) 89 | | alloca(irtype:t) 90 | | load(irval:ptr) 91 | | getelementptr(irval:ptr, . *irval:idxs) 92 | | getelementptr_inbounds(irval:ptr, . *irval:idxs) 93 | | convop(irconvop:op, irval:v, irtype:t) 94 | | icmp(iricond:vcond, irval:lhs, irval:rhs) 95 | | fcmp(irfcond:vcond, irval:lhs, irval:rhs) 96 | | phi(irtype:t, .*irphi:dsts) 97 | | select(irval:vif, irval:vthen, irval:velse) 98 | | call(ident:fn, .*irval:args) 99 | | callptr(irval:fn, .*irval:args) 100 | | callptrstd(irval:fn, .*irval:args) 101 | | ptr(irval:src, irtype:dst) 102 | | inline(irtype:t, *irval:args, any:code) 103 | ; 104 | } 105 | -------------------------------------------------------------------------------- /backend/backend.hl: -------------------------------------------------------------------------------- 1 | 2 | include "./ssa-ast.hl" 3 | 4 | include "./ll-ast.hl" 5 | include "./ll-typing.hl" 6 | include "./ll-inline.hl" 7 | include "./ll-opt.hl" 8 | 9 | include "./ir2ssa.hl" 10 | include "./passmgr.hl" 11 | include "./ir2remove-phi.hl" 12 | 13 | 14 | -------------------------------------------------------------------------------- /backend/ir2remove-phi.hl: -------------------------------------------------------------------------------- 1 | function ir2remove_phis_pass(body, bbs, regs, ret, vargs) 2 | { 3 | collector(phivaradd, phivarget) { 4 | inss = mkhash(); phiz = mkhash(); 5 | visit:ir2(ircode: body) { 6 | deep irpair : e(nm); 7 | deep irexpr { 8 | phi -> fun(tgt) { 9 | ntgt = gensym(); 10 | phivaradd([tgt;t;ntgt]); ohashput(phiz, tgt, ntgt); 11 | iter [v;d] in dsts do 12 | ohashput(inss, d, [v;ntgt]:ohashget(inss, d))} 13 | | else -> fun(tgt) [] 14 | }}; 15 | phis = phivarget(); 16 | return visit:ir2(ircode: body) { 17 | deep irbblock { 18 | bblock -> { 19 | hdr = if(name==='entry') { 20 | map [pnm;ptp;npnm] in phis do [npnm; 'alloca'(ptp)] 21 | } else []; 22 | ptl = map [v;tgt] in ohashget(inss, name) do { 23 | [gensym(); 'store'('var'(tgt), v)] 24 | }; 25 | return mk:node(c = hdr :: c :: ptl) 26 | } 27 | }; 28 | deep irpair : [nm; e(nm)]; 29 | deep irexpr { 30 | phi -> fun(tgt) 'load'('var'(ohashget(phiz, tgt))) 31 | | else -> fun(tgt) node 32 | }; 33 | } 34 | } 35 | } -------------------------------------------------------------------------------- /backend/ir2ssa.hl: -------------------------------------------------------------------------------- 1 | 2 | function il2ssa_irval_var(v) 3 | visit:ir2(irval: v) { 4 | once irval { 5 | var -> nm 6 | | else -> [] 7 | } 8 | } 9 | 10 | function il2ssa_use(e) 11 | collector(add, get) { 12 | iter:ir2(irexpr: e) { 13 | once irval { 14 | var -> add(nm) 15 | | else -> [] 16 | } 17 | }; 18 | return unifiq(get()) 19 | } 20 | 21 | function il2ssa_term_labels(t) 22 | collector(add, get) { 23 | iter:ir2(irterm: t) { 24 | once irlabel : add(node); 25 | }; 26 | return unifiq(get()) 27 | } 28 | 29 | function il2ssa_term_uses(t) 30 | collector(add, get) { 31 | iter:ir2(irterm: t) { 32 | once irval { 33 | var -> add(nm) 34 | | else -> [] 35 | } 36 | }; 37 | return unifiq(get()) 38 | } 39 | 40 | function il2ssa_genssa(code) 41 | collector(add, get) { 42 | consts = mkhash(); otyps = mkhash(); 43 | return [ /* A list: [consts; gencode; allocas; otyps] */ 44 | // consts: 45 | consts; 46 | // gencode: 47 | visit:ir2(ircode: code) { 48 | deep irbblock { 49 | bblock -> { 50 | = t; 51 | 'b'(name, c::[[%Sm<<(name,"__EXIT");'use'(@tuses)]], tl) 52 | } 53 | }; 54 | once irterm : forall { 55 | il2ssa_term_uses(node):il2ssa_term_labels(node); 56 | }; 57 | once irexpr { 58 | load -> { p = il2ssa_irval_var(ptr); 59 | if(p) 'load'(p) else 'use'() } 60 | | store -> { d1 = il2ssa_irval_var(ptr); 61 | e0 = il2ssa_irval_var(e); 62 | e1 = if(e0) e0 else { 63 | nm = gensym(); 64 | ohashput(consts, nm, e); 65 | return nm 66 | }; 67 | if(d1) { 68 | 'store'(d1,e1) 69 | } else { 'use'(@il2ssa_use(node)) } 70 | } 71 | | alloca -> { 72 | add(caar(stack)); 73 | ohashput(otyps, caar(stack), t); 74 | return 'store'(caar(stack),'_UNDEF') 75 | } 76 | | else -> 'use'(@il2ssa_use(node)) 77 | }; 78 | deep irpair : { 79 | if(nm) node else [gensym(); e] 80 | }; 81 | }; 82 | // allocas: 83 | get(); 84 | // otyps: 85 | otyps] 86 | } 87 | 88 | function il2ssa_dossa(code) { 89 | // Prepare the genssa form 90 | <[consts; gencode; allocas; otyps]> = il2ssa_genssa(code); 91 | // Refine the list of allocas 92 | noalloc = mkhash(); 93 | donotalloc(ns) = { 94 | iter n in ns do if n { 95 | ohashput(noalloc, n, true) 96 | } 97 | }; 98 | visit:ir2(ircode: code) { 99 | once irexpr { 100 | | load -> [] 101 | | store -> donotalloc([il2ssa_irval_var(e)]) 102 | | else -> donotalloc(il2ssa_use(node)) 103 | } 104 | }; 105 | // Perform the genssa mumbo-jumbo 106 | nallocas = filter a in allocas as not(ohashget(noalloc, a)); 107 | nssa = ssa_transform(gencode, nallocas); 108 | return [consts; nallocas; nssa; otyps] 109 | } 110 | 111 | function il2ssa_fullssa(code) 112 | { 113 | <[consts; nallocas; nssa; otyps]> = il2ssa_dossa(code); 114 | <[vmap;ngen;DT]> = nssa; 115 | loops = ssa_find_loops(ngen, DT); 116 | 117 | origtype(nm) = ohashget(otyps, nm); 118 | // Decode the genssa representation: fill the hashtables 119 | genh = mkhash(); 120 | remap0(n) = { 121 | do loop(x = ohashget(vmap, n), p = n) { 122 | if(x) return loop(ohashget(vmap, x), x) 123 | else return p }}; 124 | remap(n) = { 125 | n0 = remap0(n); 126 | chk = ohashget(consts, n0); 127 | if(chk) chk else 'var'(n0) 128 | }; 129 | nah = mkhash(); iter a in nallocas do ohashput(nah, a, a); 130 | nahp(n) = ohashget(nah, n); 131 | nahv(v) = { 132 | match v with 133 | var(nm) -> nahp(nm) 134 | | else -> [] 135 | }; 136 | still = mkhash(); 137 | stillthere(k) = ohashget(still, k); 138 | markpresense(k) = ohashput(still, k, k); 139 | visit:genssa(code: ngen) { 140 | deep bblock { b -> iter ops do ops(name) }; 141 | deep oppair : fun(bb) { markpresense(name); op(bb, name) }; 142 | deep iop { 143 | phi -> fun(bb, tgt) { 144 | nphi = [tgt;'phi'(origtype(orig), @zip(map vals do remap(vals), prevs))]; 145 | ohashput(genh, bb, 146 | ohashget(genh, bb)::[nphi]) } 147 | | else -> fun(bb, tgt) {[]} }}; 148 | // Apply the decoded remapping and phi insertion: 149 | ret = visit:ir2(ircode: code) { 150 | deep irbblock { 151 | bblock -> 152 | mk:node(c = ohashget(genh, name) :: map append [k;v] in c do 153 | if (v && stillthere(k)) [[k;v]] else []) 154 | }; 155 | deep irexpr { 156 | alloca -> if(nahp(caar(stack))) [] else node 157 | | load -> if(nahv(ptr)) [] else node 158 | | store -> if(nahv(ptr)) [] else node 159 | | else -> node 160 | }; 161 | deep irval { 162 | var -> { 163 | chk = remap(nm); 164 | if(chk) chk else node 165 | } 166 | | else -> node 167 | }; 168 | }; 169 | 170 | return [['loops'(cadr(loops))];ret] 171 | } -------------------------------------------------------------------------------- /backend/ll-ast.hl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | A slightly refined version of the LLVM IR AST 4 | 5 | */ 6 | 7 | 8 | ast ir2 { 9 | 10 | irmodule is (.*irtoplevel:tls); 11 | 12 | irtoplevel = 13 | %function(*ircallconv:cc, ident:name, irtype:ret, bool:va, *irarg:args, ircode:body, any:annotations) 14 | | eglobal(ident:name, irtype:type) 15 | | global(ident:name, irtype:type, irval:v) // v = const only! 16 | | comment(anything:x) 17 | ; 18 | 19 | ircode is (.*irbblock:bs); 20 | irbblock = 21 | bblock(ident:name, *irpair:c, irterm:t); 22 | irarg is (irtype:type, ident:name); 23 | irlabel is (.ident:nm); 24 | 25 | irpair is (ident:nm, irexpr:e); 26 | 27 | irval = 28 | false() 29 | | true() 30 | | null(irtype:t) 31 | | integer(int:v, .*ident:itp) 32 | | float(float:v, .*ident:ftp) 33 | | struct(. *irstructel:elts) 34 | | array(irtype:t, . *irval:elts) 35 | | vector(. *irval:elts) 36 | | zero(irtype:t) 37 | | undef(irtype:t) 38 | | blockaddress(ident:fn, ident:blk) 39 | | var(ident:nm) 40 | | global(ident:nm) 41 | | globalfun(ident:nm) 42 | | sizeof(irtype:t) 43 | // Useful for various backend legalisers 44 | | jumptable(irlabel:rel, .*irlabel:vs) 45 | ; 46 | 47 | irstructel is (irtype:t, irval:v); 48 | 49 | irtype = 50 | integer(ident:type) 51 | | float(ident:ftype) 52 | | label() 53 | | void() 54 | | array(*int:dims, irtype:t, .*aspace:spc) 55 | | %function(irtype:ret, .*irtype:args) 56 | | varfunction(irtype:ret, .*irtype:args) 57 | | struct(ident:nm, . *irtype:elts) 58 | | structref(ident:nm) 59 | | packed(ident:nm, . *irtype:elts) 60 | | pointer(irtype:t, .*aspace:spc) 61 | | vector(int:n, irtype:t) 62 | | alias(ident:id) 63 | ; 64 | 65 | irterm = /* More or less the same as terminal instructions, 66 | with 'store' moved here and 'invoke' moved to irexpr */ 67 | | ret(irval:value) 68 | | vret() 69 | | br(irval:cnd, irlabel:tr, irlabel:fl) 70 | | br_label(irlabel:nm) 71 | | switch(irval:value, irlabel:els, *irswitchdst:cases) 72 | | indirectbr(any:t, irval:addr, *irlabel:ds) 73 | /* No invoke here, since it returns a value */ 74 | | unwind() 75 | | unreacheable() 76 | // For backends 77 | | indirectbr_jt(irlabel:relname, irval:addr, .*irlabel:ds) 78 | ; 79 | 80 | irswitchdst is ( irval:value, irlabel:dst ); 81 | irphi is (irval:value, irlabel:dst); 82 | 83 | irexpr = 84 | | string(string:s) 85 | | volatile_store(irtype:t, irval:value, irtype:ty, irval:ptr, *irval:align) 86 | | store(irval:ptr, irval:e) 87 | | binary(irbinop:op, irval:l, irval:r) 88 | | extractelement(int:n, irval:v, irval:idx) 89 | | insertelement(int:n, irtype:t, irval:v, irval:elt, irval:idx) 90 | | shufflevector(int:n1, irval:val1, int:n2, irval:val2, irval:mask) 91 | | extractvalue(iraggtype:t, irval:v, irval:idx) 92 | | insertvalue(irval:v, irtype:tv, irval:elt, irval:idx) 93 | | alloca(irtype:t,.*ident:varname) 94 | | load(irval:ptr) 95 | | getelementptr(irval:ptr, *irval:idxs, .*irtype:ptrtp) 96 | | getelementptr_inbounds(irval:ptr, *irval:idxs, .*irtype:ptrtp) 97 | | convop(irconvop:op, irval:v, irtype:t) 98 | | icmp(iricond:vcond, irval:lhs, irval:rhs) 99 | | fcmp(irfcond:vcond, irval:lhs, irval:rhs) 100 | | phi(irtype:t, .*irphi:dsts) 101 | | select(irval:vif, irval:vthen, irval:velse) 102 | | call(ident:fn, .*irval:args) 103 | | callptr(irval:fn, .*irval:args) 104 | | callptrstd(irval:fn, .*irval:args) 105 | | ptr(irval:src, irtype:dst) 106 | | inline(irtype:t, *irval:args, any:code) 107 | ; 108 | } 109 | -------------------------------------------------------------------------------- /backend/ll-inline.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Inlining direct function calls} 4 | 5 | Inlining involves splitting basic blocks and inserting a number of new basic 6 | blocks in between. It worth abstracting this out into an intermediate step: 7 | 8 | \pfcode{ 9 | ast ir2split: ir2 () { 10 | irexpr += splitbb(ident:entry, ident:nxt, *irbblock:newbbs); 11 | }} 12 | 13 | \pfcode{ 14 | function ir2split_flatten(fnc) collector(bbadd, bbget) { 15 | fixphis = mkhash(); 16 | visit:ir2split(irtoplevel:fnc) { 17 | deep irpair: e(nm); 18 | once irexpr { 19 | splitbb -> fun(nm) 'SPLIT'(entry, nxt, newbbs) 20 | | else -> fun(nm) [nm;node]}; 21 | deep irbblock { 22 | bblock -> { 23 | // keep everything prior to bbsplit, 24 | // replace terminal with br to split entry, 25 | // create a new basic block 'nxt' with the rest 26 | // and the old terminal 27 | // 28 | // Note that it's possible to have multiple splits in a single 29 | // basic block. 30 | do loop (cs = c, acc = collector(add,get) add:get, thislbl = name) { 31 | match cs with 32 | 'SPLIT'(entry, nxt, newbbs):rest -> { 33 | // Terminate the current basic block 34 | code = (cdr(acc))(); 35 | newbb = 'bblock'(thislbl, code, 'br_label'(entry)); 36 | bbadd(newbb); 37 | // Add the inlined basic blocks 38 | iter b in newbbs do bbadd(b); 39 | // Start a new basic block and carry on 40 | loop(rest, collector(add,get) add:get, nxt) 41 | } 42 | | hd : tl -> {(car(acc))(hd); loop(tl, acc, thislbl)} 43 | | [] -> { 44 | code = (cdr(acc))(); 45 | if (not(thislbl === name)) { 46 | ohashput(fixphis, name, thislbl); 47 | }; 48 | newbb = 'bblock'(thislbl, code, t); 49 | bbadd(newbb);}}}}}; 50 | pass1 = bbget(); 51 | pass2 = visit:ir2(ircode: pass1) { 52 | deep irphi: {chk = ohashget(fixphis, dst); 53 | if(chk) mk:node(dst=chk) else node}}; 54 | return visit:ir2(irtoplevel: fnc) { 55 | once irtoplevel { 56 | %function -> mk:node(body=pass2) | else -> []}}; 57 | }} 58 | 59 | \pfcode{ 60 | function ir2_inline_function_body(dstdef, entry, retdst, nxt, callargs) { 61 | // rename entry, give new names to all the other bbs, substitute args, 62 | // replace return with dst binding (if not void) and branch to nxt 63 | collect ir2 (irtoplevel: dstdef) with 64 | bbs from irbblock.bblock.name { 65 | newnames = mkhash(); 66 | newnm(k) = { 67 | nnm = if(k==='entry') entry else gensym(); 68 | ohashput(newnames, k, nnm)}; 69 | hashiter(fun(k,v) { newnm(k) }, bbs); 70 | iter:ir2(irtoplevel:dstdef) { 71 | deep irval { 72 | jumptable -> newnm(rel) 73 | | else -> []}}; 74 | rettp = visit:ir2(irtoplevel: dstdef) { 75 | once irtoplevel { %function -> ret | else -> [] }}; 76 | argsh = mkhash(); 77 | visit:ir2(irtoplevel: dstdef) { 78 | once irarg: name; 79 | deep irtoplevel { 80 | %function -> 81 | iter [a;v] in zip(args,callargs) do ohashput(argsh, a, v) 82 | | else -> []}}; 83 | // 1. rename labels 84 | pass1 = visit:ir2(irtoplevel: dstdef) { 85 | deep irtoplevel { 86 | %function -> body 87 | | else -> [] // error? 88 | }; 89 | deep irbblock { 90 | bblock -> mk:node(name = ohashget(newnames, name)) 91 | }; 92 | deep irlabel: {chk = ohashget(newnames, node); 93 | if(chk) chk else node}}; 94 | // 2. substitute arguments 95 | pass2 = visit:ir2(ircode: pass1) { 96 | deep irval { 97 | var -> {chk = ohashget(argsh, nm); 98 | if (chk) chk else node} 99 | | else -> node}}; 100 | // 3. Return 101 | pass4 = collector(addret, getrets) { 102 | tmpnxt = if(retdst==='_') nxt else gensym(); 103 | pass3 = visit:ir2(ircode: pass2) { 104 | deep irbblock { 105 | bblock -> mk:node(t=t(name))}; 106 | deep irterm { 107 | vret -> fun(bblbl) 'br_label'(tmpnxt) 108 | | ret -> fun(bblbl) { 109 | addret([value;bblbl]); 110 | 'br_label'(tmpnxt)} 111 | | else -> fun(bblbl) node}}; 112 | rets = getrets(); 113 | retblock = if(retdst==='_') [] else ['bblock'(tmpnxt, [[retdst;'phi'(rettp, @rets)]], 'br_label'(nxt))]; 114 | [@retblock;@pass3]; // pass4 115 | }; 116 | // 5. Rename all the variables 117 | newvarnames = mkhash(); 118 | iter:ir2(ircode:pass4) { 119 | once irpair: { 120 | if (not(nm === '_') && not(nm === retdst)) symbols(nnm) { 121 | ohashput(newvarnames, nm, nnm)}}}; 122 | pass5 = visit:ir2(ircode:pass4) { 123 | deep irpair: { 124 | chk = ohashget(newvarnames, nm); 125 | if(chk) mk:node(nm=chk) else node}; 126 | deep irval { 127 | var -> { 128 | chk = ohashget(newvarnames, nm); 129 | if(chk) mk:node(nm=chk) else node} 130 | | else -> node}}; 131 | return pass5}}} 132 | 133 | \pfcode{ 134 | function ir2_inline_function(fns, prevfns, pred, fnc) 135 | visit:ir2(irtoplevel: fnc) { 136 | deep irpair: e(nm); 137 | deep irexpr { 138 | call -> fun(retdst) { 139 | dstdef0 = ohashget(fns, fn); 140 | dstdef = if (pred(dstdef0)) dstdef0 else ohashget(prevfns, fn); 141 | if (pred(dstdef)) symbols(entry, nxt) { // inline it 142 | [[];'splitbb'(entry, nxt, 143 | ir2_inline_function_body(dstdef, entry, retdst, nxt, args))] 144 | } else [retdst;node] 145 | } 146 | | else -> fun(dst) [dst;node] 147 | } 148 | } 149 | } 150 | 151 | \pfcode{ 152 | function ir2_inline(pred, mdl, metamdl) 153 | collect ir2 (irmodule: metamdl) with 154 | prevfns from irtoplevel. %function . name { 155 | collect ir2 (irmodule: mdl) with 156 | fns from irtoplevel. %function . name { 157 | visit:ir2(irmodule: mdl) { 158 | deep irtoplevel { 159 | %function -> if (body) 160 | ir2split_flatten( 161 | ir2_inline_function(fns, prevfns, pred, node)) 162 | else node 163 | | else -> node}}}}} 164 | 165 | 166 | %%%%%%%%% -------------------------------------------------------------------------------- /backend/ll-opt-back.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | 4 | \pfcode{ 5 | parser genssa2_intrinsic () { 6 | @ni1tkn := (!":" .)+; 7 | ni1 := [ni1tkn]:s => $sval(s); 8 | genssa2_intrinsic := { [ni1]:l ":" [ni1]:r => pair(l,r) } 9 | / [ni1]; 10 | } 11 | 12 | function genssa2_to_ll_parse_intrinsic(dst) { 13 | ret = parse %S<<(dst) as genssa2_intrinsic; 14 | match ret with 15 | pair(l,r) -> l:r 16 | | e -> e:[]}} 17 | 18 | \pfcode{ 19 | function ll_strip_annotations(l) { 20 | map append l do 21 | match l with 22 | 'loops'(@_) -> [] 23 | | else -> [l]}} 24 | 25 | \pfcode{ 26 | %"Reverse transform from genssa2 back to ir2" 27 | function genssa2_to_ll(src0, src, types) { 28 | doconst(tp, vl) = { 29 | match vl with 30 | 'ir2_type'(t) -> t 31 | | 'zero'('ir2_type'(t)) -> 'zero'(t) 32 | | 'sizeof'('ir2_type'(t)) -> 'sizeof'(t) 33 | | else -> vl 34 | }; 35 | doother(tp, vl) = doconst(tp, vl); 36 | gettype(dstreg) = { 37 | aif(chk = ohashget(types, dstreg)) chk 38 | else 'alias'('*unknown*')}; 39 | docall(dst, attr, args) = { 40 | = genssa2_to_ll_parse_intrinsic(dst); 41 | case pdst { 42 | | 'ir2-string' -> 'string'(@args) 43 | | 'ir2-volatile_store' -> 'volatile_store'(@args) 44 | | 'ir2-store' -> 'store'(@args) 45 | | 'ir2-binop' -> 'binary'(rest, @args) 46 | | 'ir2-extractelement' -> 'extractelement'(@args) 47 | | 'ir2-insertelement' -> 'insertelement'(@args) 48 | | 'ir2-shufflevector' -> 'shufflevector'(@args) 49 | | 'ir2-extractvalue' -> 'extractvalue'(@args) 50 | | 'ir2-insertvalue' -> 'insertvalue'(@args) 51 | | 'ir2-alloca' -> 'alloca'(@args) 52 | | 'ir2-load' -> 'load'(@args) 53 | | 'ir2-getelementptr' -> { 54 | <[ptr;@idxs]> = args; 55 | 'getelementptr'(ptr, idxs)} 56 | | 'ir2-getelementptr_inbounds' -> { 57 | <[ptr;@idxs]> = args; 58 | 'getelementptr_inbounds'(ptr, idxs)} 59 | | 'ir2-convop' -> 'convop'(rest, @args) 60 | | 'ir2-icmp' -> 'icmp'(rest, @args) 61 | | 'ir2-fcmp' -> 'fcmp'(rest, @args) 62 | | 'ir2-call' -> 'call'(@args) 63 | | 'ir2-callptr' -> 'callptr'(@args) 64 | | 'ir2-callptrstd' -> 'callptrstd'(@args) 65 | | 'ir2-ptr' -> 'ptr'(@args) 66 | | 'ir2-inline' -> { 67 | <[t;cde;@rargs]> = args; 68 | 'inline'(t,rargs, cde) 69 | } 70 | 71 | | 'ir2-ret' -> 'TERM'('ret'(@args)) 72 | | 'ir2-vret' -> 'TERM'('vret'(@args)) 73 | | else -> ccerror('ERROR'(dst,@args)) 74 | }}; 75 | 76 | splitops(ops) = 77 | collector(ladd, lget) 78 | collector(radd, rget) { 79 | iter o in ops do { 80 | match o with 81 | [nm;TERM(t)] -> radd(t) 82 | | [nm;[]] -> [] 83 | | else -> ladd(o)}; 84 | r0 = rget(); 85 | r = if(r0) car(r0) else []; 86 | return [lget(); r]}; 87 | 88 | dobody() = 89 | visit:genssa2(top:src) { 90 | deep top { f -> body }; 91 | deep bblock { 92 | b -> { 93 | <[ops1;term1]> = splitops(ops); 94 | 'bblock'(name, ops1, if(term1) term1 else t)}}; 95 | deep oppair: [name; op(name)]; 96 | deep phiarg { a -> [v; src]}; 97 | deep iop(dstreg) { 98 | phi -> 'phi'(gettype(dstreg), @args) 99 | | select -> 'select'(cnd, t, f) 100 | | call -> { 101 | if (filter a as match a with 'intrinsic'() -> true) { 102 | return { 103 | 'call'(dst, @args) 104 | } 105 | } else docall(dst, a, args)}}; 106 | deep expr { 107 | var -> 'var'(id) 108 | | glob -> 'global'(id) 109 | | const -> doconst(t, v) 110 | | other -> doother(t, v)}; 111 | deep term { 112 | br -> 'br_label'(dst) 113 | | brc -> 'br'(c, tr, fl) 114 | | switch -> 'switch'(v, d, ns) 115 | | indirect -> car(orig) // TODO: verify the names of the targets 116 | | none -> 'unreacheable'()}}; 117 | newbody = dobody(); 118 | return visit:ir2(irtoplevel: src0) { 119 | once irtoplevel { 120 | %function -> { 121 | // TODO: strip only the loop annotations 122 | mk:node(body = newbody, annotations = ll_strip_annotations(annotations))} 123 | | else -> node}}}} 124 | 125 | 126 | \pfcode{ 127 | function ll_clean_pragmas(iadd, top) { 128 | is_intrinsic(dst) = { 129 | ret = parse %S<<(dst) as genssa2_fun_intrinsic; 130 | match ret with 131 | 'intrinsic'() -> true 132 | | else -> []}; 133 | visit:ir2 (irtoplevel: top) { 134 | deep irbblock { 135 | bblock -> mk:node(c = map append c in c do c(name))}; 136 | deep irpair: fun(bbname) e(nm, bbname); 137 | deep irexpr (dstnm, bbname) { 138 | call -> 139 | if (is_intrinsic(fn)) {iadd([bbname; dstnm; node]); return []} 140 | else [[dstnm; node]] 141 | | else -> [[dstnm; node]]}}}} 142 | 143 | %%%%%%%%%%%%%%%%%%%% -------------------------------------------------------------------------------- /backend/ll-opt-model.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Language model for the abstract SSA passes} 4 | 5 | \pfcode{ 6 | function ll_const_type_c(lenv, vl) { 7 | untype(t) = { 8 | match t with 9 | 'ir2_type'(x) -> x 10 | | else -> t}; 11 | visit:ir2(irval: vl) { 12 | once irval { 13 | false -> 'integer'('i32') 14 | | true -> 'integer'('i32') 15 | | sizeof -> 'integer'('i32') 16 | | null -> untype(t) 17 | | integer -> 'integer'(if(itp) car(itp) else 'i32') 18 | | float -> 'float'(if(ftp) car(ftp) else 'f32') 19 | | struct -> 'struct'(gensym(), @map [t;v] in elts do t) 20 | | array -> 'array'(t, [length(elts)]) 21 | | zero -> untype(t) 22 | | undef -> untype(t) 23 | | blockaddress -> 'pointer'('void'()) // is it really? 24 | | jumptable -> 'pointer'('integer'('i32')) // not quite 25 | | var -> 'var'(nm) 26 | | global -> { 27 | chk1 = ll_env_getglobal(lenv, nm); 28 | if (chk1) return 'pointer'(chk1) 29 | else 'var'(nm)} 30 | | else -> 'var'(%Sm<<("X1_",gensym()))}}}} 31 | } 32 | 33 | \pfcode{ 34 | function shlf(a, b) notnet(int a, int b) {leave a< x 43 | | else -> t}; 44 | getzero(tp) = { 45 | visit:ir2(irtype:tp) { 46 | once irtype { 47 | integer -> 0 48 | | float -> %flt:parse("0.0") 49 | | pointer -> 0 50 | | else -> 0 51 | }}}; 52 | getir2constval(c) = 53 | visit:ir2(irval:c) { once irval { 54 | false -> 0 55 | | true -> 1 56 | | null -> [] 57 | | integer -> v 58 | | float -> %flt:parse(%S<<(v)) 59 | | zero -> getzero(cadr(t)) 60 | | else -> {'unknown'(c)} 61 | }}; 62 | getir2consttype(c) = 63 | visit:ir2(irval:c) { once irval { 64 | false -> 'boolean'() 65 | | true -> 'boolean'() 66 | | null -> t 67 | | integer -> 'integer'(@itp) 68 | | float -> 'float'(@ftp) 69 | | zero -> untype(t) 70 | | else -> {'unknown'(c)} 71 | }}; 72 | mkconst(tp, v) = { 73 | match tp with 74 | 'integer'(@itp) -> 'const'('ir2const'(),'integer'(v,@itp)) 75 | | 'float'(@ftp) -> 'const'('ir2const'(),'float'(%->s(v),@ftp)) 76 | | 'boolean'() -> 'const'('ir2const'(), if(v==0) 'false'() else 'true'()) 77 | | else -> 'const'('ir2fail'(),'const'(tp,v)) //TODO 78 | }; 79 | mkboolconst(v) = 80 | if(v && not(v==0)) 'const'('ir2const'(), 'true'()) 81 | else 'const'('ir2const'(), 'false'()); 82 | gettype(t) = {match t with 83 | 'const'(t0, ir2c) -> getir2consttype(ir2c) 84 | | else -> {'unknown'(t)}}; 85 | getval(t) = {match t with 86 | 'const'(t0, ir2c) -> getir2constval(ir2c) 87 | | else -> {'unknown'(t)}}; 88 | istrueconst(t) = { 89 | val = getval(t); 90 | if (not(val) || val==0) [] else #t}; 91 | mkbinfun(f) = 92 | fun(args) { 93 | match args with 94 | [l;r] -> { 95 | tp = gettype(l); 96 | vl = getval(l); 97 | vr = getval(r); 98 | return mkconst(tp, f(vl, vr))}}; 99 | 100 | mkboolfun(f) = 101 | fun(args) { 102 | match args with 103 | [l;r] -> { 104 | vl = getval(l); 105 | vr = getval(r); 106 | return mkboolconst(f(vl, vr))}}; 107 | 108 | 109 | typeqnfun(lenv, eqadd, dstreg, dst, args) = { 110 | = genssa2_to_ll_parse_intrinsic(dst); 111 | eq(l, r) = eqadd('equals'(l, r)); 112 | setdst(r) = eq('var'(dstreg), r); 113 | mkptr(t) = 'pointer'(t); 114 | booltype = 'integer'('i32'); 115 | case l { 116 | | 'ir2-string' -> [] 117 | | 'ir2-binop' -> {iter a in args do setdst(a)} 118 | | 'ir2-extractelement' -> [] 119 | | 'ir2-insertelement' -> [] 120 | | 'ir2-shufflevector' -> [] 121 | | 'ir2-extractvalue' -> [] 122 | | 'ir2-insertvalue' -> [] 123 | | 'ir2-alloca' -> setdst(mkptr(car(args))) 124 | | 'ir2-load' -> eq(car(args),mkptr('var'(dstreg))) 125 | | 'ir2-getelementptr' -> [] 126 | | 'ir2-getelementptr_inbounds' -> [] 127 | | 'ir2-convop' -> setdst(cadr(args)) 128 | | 'ir2-icmp' -> {eq(car(args),cadr(args)); setdst(booltype)} 129 | | 'ir2-fcmp' -> {eq(car(args),cadr(args)); setdst(booltype)} 130 | | 'ir2-call' -> {fn = car(args); 131 | tp = ll_env_fun_retval(lenv, fn); 132 | if (tp) setdst(tp) else 'var'(gensym())} 133 | | 'ir2-callptr' -> [] 134 | | 'ir2-callptrstd' -> [] 135 | | 'ir2-ptr' -> [] 136 | | 'ir2-inline' -> [] 137 | 138 | | 'ir2-ret' -> eq(car(args), 'var'('*return*')) 139 | | 'ir2-vret' -> [] 140 | } 141 | }; 142 | 143 | typemkfun(lenv, t) = { 144 | match t with 145 | 'ir2_type'(t) -> t 146 | | else -> 'var'(%Sm<<("X3_",gensym()))}; 147 | 148 | ctypemkfun(lenv, t, c) = { 149 | match t with 150 | 'ir2type'() -> typemkfun(lenv, c) 151 | | 'int'() -> 'integer'('i32') 152 | | 'ir2const'() -> ll_const_type_c(lenv, c) 153 | | 'globfun'() -> c // special case, not a type 154 | | else -> 'var'(%Sm<<("X2_",gensym()))}; 155 | 156 | iter [nm;c;p;efun;@rst] in [ 157 | ['ir2-binop:Add';1;1;mkbinfun( %+ );'add']; 158 | ['ir2-binop:Sub';1;1;mkbinfun( %- );'sub']; 159 | ['ir2-binop:Mul';1;1;mkbinfun( %* );'mul']; 160 | 161 | ['ir2-binop:Shl';1;1;mkbinfun( %shlf )]; 162 | 163 | ['ir2-binop:SRem';1;1;mkbinfun( fun(l,r) (l mod r) )]; 164 | 165 | ['ir2-binop:FAdd';1;1;mkbinfun( %f+ )]; 166 | ['ir2-binop:FSub';1;1;mkbinfun( %f- )]; 167 | ['ir2-binop:FMul';1;1;mkbinfun( %f* )]; 168 | 169 | ['ir2-convop:ZExt';1;1; fun(args) { 170 | tp = untype(caddr(cadr(args))); 171 | mkconst(tp, getval(car(args)))}]; 172 | 173 | ['ir2-convop:Trunc';1;1; fun(args) { 174 | tp = untype(caddr(cadr(args))); 175 | mkconst(tp, getval(car(args)))}]; 176 | 177 | ['ir2-convop:FPTrunc';1;1; fun(args) { 178 | tp = untype(caddr(cadr(args))); 179 | mkconst(tp, %S<<(getval(car(args)))) 180 | }]; 181 | 182 | /* 183 | ['ir2-convop:SIToFP';1;1; fun(args) { 184 | tp = untype(caddr(cadr(args))); 185 | ret=mkconst(tp, getval(car(args))); 186 | ret 187 | }]; */ 188 | 189 | ['ir2-convop:SExt';1;1; fun(args) { 190 | tp = untype(caddr(cadr(args))); 191 | ret=mkconst(tp, getval(car(args))); 192 | ret 193 | }]; 194 | 195 | ['ir2-convop:BitCast';[];1;[]]; 196 | 197 | ['ir2-icmp:NE';1;1;mkboolfun( fun(l,r) l!=r );'neq']; 198 | ['ir2-icmp:EQ';1;1;mkboolfun( fun(l,r) l==r );'eq']; 199 | ['ir2-icmp:SLT';1;1;mkboolfun( %< );'lt']; 200 | ['ir2-icmp:SLE';1;1;mkboolfun( %<= );'le']; 201 | ['ir2-icmp:SGT';1;1;mkboolfun( %> );'gr']; 202 | ['ir2-icmp:SGE';1;1;mkboolfun( %>= );'ge'] 203 | 204 | ] do { 205 | cls = if (rst) car(rst) else []; 206 | ohashput(ht, nm, fun(tg) { 207 | match tg with 208 | 'constantp' -> c 209 | | 'purep' -> p 210 | | 'evalfun' -> efun 211 | | 'classify' -> cls})}; 212 | ohashput(ht, '*true?*', istrueconst); 213 | 214 | ohashput(ht, '*boolean-type*', 'integer'('i32')); 215 | ohashput(ht, '*type-maker*', typemkfun); 216 | ohashput(ht, '*ctype-maker*', ctypemkfun); 217 | ohashput(ht, '*type-equation-maker*', fun(dst) typeqnfun); 218 | 219 | ohashput(ht, '*get-integer-constant*', fun(tp, vl) { 220 | match vl with integer(x,@_) -> x | else -> []}); 221 | 222 | if(passes) ohashput(ht, '*userpasses*', passes); 223 | 224 | return ht}; 225 | } 226 | 227 | \pfcode{ 228 | define ll_env = ll_mk_env([]) 229 | } 230 | 231 | 232 | %%%%%%%%%% -------------------------------------------------------------------------------- /backend/ll-opt-there.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | 4 | \subsection{IL2 $\to$ genssa2} 5 | 6 | 7 | \pfcode{ 8 | function ll_isconst(v) 9 | visit:ir2(irval: v){ 10 | once irval { 11 | var -> [] 12 | | global -> [] 13 | | globalfun -> [] 14 | | else -> true}}} 15 | 16 | \pfcode{ 17 | parser genssa2_fun_intrinsic () { 18 | genssa2_fun_intrinsic := "_pragma_" (.*) => intrinsic(); 19 | }} 20 | 21 | \pfcode{ 22 | function ll_to_genssa2(src) { 23 | mktype(t) = 'const'('ir2type'(), t); 24 | mkterm(dst, t) = [[%Sm<<(dst, "___TERM");t]]; 25 | is_intrinsic(dst) = { 26 | ret = parse %S<<(dst) as genssa2_fun_intrinsic; 27 | match ret with 28 | 'intrinsic'() -> true 29 | | else -> []}; 30 | visit:ir2(irtoplevel: src) { 31 | deep irtoplevel { 32 | %function -> 'f'(name, ret, args, body) 33 | | else -> ccerror('IMPOSSIBLE')}; 34 | deep ircode: bs; 35 | once irtype { else -> 'ir2_type'(node) }; 36 | deep irbblock { 37 | bblock -> { 38 | <[xx; t1]> = t(name); 39 | 'b'(name, c::xx, t1)}}; 40 | deep irarg: {[type; name]}; 41 | deep irpair: {[nm; e]}; 42 | deep irval { 43 | var -> 'var'(nm) 44 | | else -> if (ll_isconst(node)) 'const'('ir2const'(), node) else 'other'('ir2'(),node) 45 | }; 46 | deep irphi: {'a'(dst, value)}; 47 | deep irexpr { // -> iop 48 | phi -> 'phi'(@dsts) 49 | | string -> 'call'([], 'ir2-string', 'const'('ir2string'(), s)) 50 | | volatile_store -> 'call'([], 'ir2-volatile_store', 51 | mktype(t), 52 | value, mktype(ty), 53 | ptr, @align) 54 | | store -> 'call'([], 'ir2-store', ptr, e) 55 | | binary -> 'call'([], %Sm<<('ir2-binop:',op), l, r) 56 | | extractelement -> 'call'([], 'ir2-extractelement', 57 | 'const'('int'(),n), 58 | v, idx) 59 | | insertelement -> 'call'([], 'ir2-insertelement', 60 | 'const'('int'(), n), 61 | mktype(t), 62 | v, elt, idx) 63 | | shufflevector -> 'call'([], 'ir2-shufflevector', 64 | 'const'('int'(), n1), 65 | val1, 66 | 'const'('int'(), n2), 67 | val2, mask) 68 | 69 | | extractvalue -> 'call'([], 'ir2-extractvalue', 'const'('ir2aggtype'(), t), v, idx) 70 | | insertvalue -> 'call'([], 'ir2-insertvalue', v, mktype(tv), elt, idx) 71 | | alloca -> 'call'([], 'ir2-alloca', mktype(t),@map n in varname do 'other'('ident'(), n)) 72 | | load -> 'call'([], 'ir2-load', ptr) 73 | | getelementptr -> 'call'([], 'ir2-getelementptr', ptr, @idxs) 74 | | getelementptr_inbounds -> 'call'([], 'ir2-getelementptr_inbounds', ptr, @idxs) 75 | | convop -> 'call'([], %Sm<<('ir2-convop:', op), v, mktype(t)) 76 | | icmp -> 'call'([], %Sm<<('ir2-icmp:', vcond), lhs, rhs) 77 | | fcmp -> 'call'([], %Sm<<('ir2-fcmp:', vcond), lhs, rhs) 78 | | select -> 79 | 'select'(vif, vthen, velse) 80 | | call -> if (is_intrinsic(fn)) 81 | 'call'(['intrinsic'()], fn, @args) 82 | else 'call'(['external'()], 'ir2-call', 'other'('globfun'(), fn),@args) 83 | | callptr -> 'call'([], 'ir2-callptr', fn, @args) 84 | | callptrstd -> 'call'([], 'ir2-callptrstd', fn, @args) 85 | | ptr -> 'call'([], 'ir2-ptr', src, mktype(dst)) 86 | | inline -> 'call'([], 'ir2-inline', mktype(t), 'const'('ir2inline'(), code), @args) 87 | }; 88 | deep irterm(dst) { 89 | ret -> [mkterm(dst, 'call'([], 'ir2-ret', value)); 'none'()] 90 | | vret -> [mkterm(dst, 'call'([], 'ir2-vret')); 'none'()] 91 | | br -> [[]; 'brc'(cnd, tr, fl)] 92 | | br_label -> [[]; 'br'(nm)] 93 | | switch -> [[]; 'switch'(value, els, @cases)] 94 | | indirectbr_jt -> [[]; 'indirect'([node],@ds)] 95 | | else -> ccerror('UNSUPPORTED') 96 | }; 97 | deep irswitchdst: {[value; dst]}; 98 | }}} 99 | 100 | 101 | %%%%%% -------------------------------------------------------------------------------- /backend/ll-opt.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Using the generic SSA library for optimisations} 4 | 5 | \phcode{include "./ssa-fold-ast.hl"} 6 | \phcode{litinclude ("./ll-opt-there") "./ll-opt-there.hl"} 7 | \phcode{litinclude ("./ll-opt-back") "./ll-opt-back.hl"} 8 | \phcode{litinclude ("./ll-opt-model") "./ll-opt-model.hl"} 9 | 10 | \pfcode{ 11 | function ll_genssa_opt(globenv, src) { 12 | /* ohashput(ll_env, '*debug-compiler-ssa*', 1); 13 | ohashput(ll_env, '*debug-compiler-ssa-timing*', 1); */ 14 | g2 = ll_to_genssa2(src); 15 | = genssa2_process(ll_env, globenv, g2); 16 | g4 = genssa2_to_ll(src, g3, g3ht); 17 | return g3ht:g4 18 | }} 19 | 20 | %%%%%%%%%%%%%%%% -------------------------------------------------------------------------------- /backend/ll-typing.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Typing for the ll-ast} 4 | 5 | 6 | \pfcode{ 7 | function ll_env_getglobal(env, nm) { 8 | return ohashget(env, %Sm<<("global-type: ", nm)) 9 | }} 10 | 11 | \pfcode{ 12 | function ll_env_fun_retval(env, nm) { 13 | return ohashget(env, %Sm<<("function-ret-type: ", nm)) 14 | }} 15 | 16 | \pfcode{ 17 | function ll_pointee_type(tp) 18 | visit:ir2(irtype: tp) { 19 | once irtype { 20 | pointer -> t 21 | | else -> ccerror('CLIKE:LL:NOTAPOINTER'(tp)) 22 | }} 23 | } 24 | 25 | \pfcode{ 26 | function ll_fun_retval(fntp) 27 | visit:ir2(irtype: fntp) { 28 | once irtype { 29 | %function -> ret 30 | | else -> ccerror('CLIKE:LL:NOTAFUNCTION'(fntp)) 31 | }} 32 | } 33 | 34 | \pfcode{ 35 | function ll_value_type_inner(env, types, vl) 36 | visit:ir2(irval: vl) { 37 | once irval { 38 | false -> 'integer'('i32') 39 | | true -> 'integer'('i32') 40 | | sizeof -> 'integer'('i32') 41 | | null -> t 42 | | integer -> 'integer'(if(itp) car(itp) else 'i32') 43 | | float -> 'float'(if(ftp) car(ftp) else 'f32') 44 | | struct -> 'struct'(gensym(), @map [t;v] in elts do t) 45 | | array -> 'array'(t, [length(elts)]) 46 | | zero -> t 47 | | undef -> t 48 | | blockaddress -> 'pointer'('void'()) // is it really? 49 | | jumptable -> 'pointer'('integer'('i32')) // not quite 50 | | var -> { 51 | chk1 = ohashget(types, nm); 52 | if (chk1) { // known local variable 53 | return chk1 54 | } else { // undiagnosed global? 55 | chk2 = ll_env_getglobal(env, nm); 56 | if (chk2) return 'pointer'(chk2) 57 | else []}} 58 | | global -> { 59 | chk1 = ll_env_getglobal(env, nm); 60 | if (chk1) return 'pointer'(chk1) 61 | else []} 62 | | else -> []}}} 63 | 64 | \pfcode{ 65 | function ll_value_type_0(env, types, vl, vis) { 66 | tp = ll_value_type_inner(env, types, vl); 67 | match tp with 68 | delay(nm, fn) -> { 69 | ohashput(types, nm, []); // anti cycle 70 | ntp = fn(nm); 71 | ohashput(types, nm, ntp); 72 | return ntp} 73 | | tryany(nm, @tps) -> 74 | if (not(ohashget(vis, nm))) { 75 | ohashput(vis, nm, nm); // anti cycle 76 | ohashput(types, nm, []); // anti cycle 77 | do loop (ts = tps) { 78 | match ts with 79 | [d;hd]: tl -> 80 | aif(chk = hd()) { 81 | ohashput(types, nm, chk); 82 | chk} 83 | else loop(tl) 84 | | else -> []}} 85 | | else -> tp}} 86 | 87 | \pfcode{ 88 | function ll_value_type(env, types, vl) 89 | ll_value_type_0(env, types, vl, mkhash())} 90 | 91 | \pfcode{ 92 | function ll_numeric_constant(v) 93 | visit:ir2(irval:v) { 94 | once irval { 95 | integer -> v 96 | | zero -> 0 97 | | null -> 0 98 | | else -> ccerror('CLIKE:LL:EXPECTCONSTANT'(v)) 99 | } 100 | }} 101 | 102 | \pfcode{ 103 | function ll_destruct_gep(tp, idxs) { 104 | rt = foldl(fun(t, i) { 105 | visit:ir2(irtype:t) { 106 | once irtype { 107 | pointer -> t 108 | | array -> t 109 | | struct -> { 110 | cnst = ll_numeric_constant(i); 111 | fld = nth(cnst, elts); 112 | return fld 113 | } 114 | | else -> t 115 | } 116 | } 117 | }, tp, idxs); 118 | return 'pointer'(rt) // TODO: preserve origin addrspace 119 | }} 120 | 121 | 122 | \pfcode{ 123 | function ll_propagate_types_fun(env, fn) { 124 | types = mkhash(); 125 | bind(nm, tp) = ohashput(types, nm, tp); 126 | is_unknown(tp) = 127 | visit:ir2(irtype: tp) { 128 | once irtype { 129 | alias -> id === '*unknown*' 130 | | else -> []}}; 131 | arraydecay(tp) = 132 | visit:ir2(irtype: tp) { 133 | once irtype { 134 | array -> t 135 | | else -> node}}; 136 | visit:ir2(irtoplevel:fn) { 137 | deep irarg: bind(name, type); 138 | deep irpair: ohashput(types, nm, 'delay'(nm, e)); 139 | deep irexpr { 140 | string -> fun(dst) bind(dst, 'pointer'('integer'('i8'))) 141 | | binary -> fun(dst) bind(dst, ll_value_type(env,types, l)) 142 | | alloca -> fun(dst) bind(dst, 'pointer'(arraydecay(t))) 143 | | load -> fun(dst) { 144 | tp = ll_value_type(env, types, ptr); 145 | vtp = ll_pointee_type(tp); 146 | bind(dst, vtp) 147 | } 148 | | getelementptr -> fun(dst) { 149 | tp = ll_value_type(env,types,ptr); 150 | eltp = ll_destruct_gep(tp, idxs); 151 | bind(dst, eltp) 152 | } 153 | | getelementptr_inbounds -> fun(dst) { 154 | tp = ll_value_type(env,types,ptr); 155 | eltp = ll_destruct_gep(tp, idxs); 156 | bind(dst, eltp) 157 | } 158 | | convop -> fun(dst) bind(dst, t) 159 | | icmp -> fun(dst) bind(dst, 'integer'('i32')) // boolean? 160 | | fcmp -> fun(dst) bind(dst, 'integer'('i32')) 161 | | phi -> fun(dst) { 162 | // After a genssa2 round trip, we'll have broken phi types everywhere. 163 | vis = mkhash(); 164 | if (is_unknown(t)) { 165 | bind(dst, 166 | 'tryany'(dst, @map d in dsts do 167 | [d;fun() 168 | ll_value_type_0(env, types, car(d), vis)])) 169 | } else bind(dst, t)} 170 | | select -> fun(dst) bind(dst, ll_value_type(env, types, vthen)) 171 | | call -> fun(dst) { 172 | tp = ll_env_fun_retval(env, fn); 173 | bind(dst, tp) 174 | } 175 | | inline -> fun(dst) { 176 | bind(dst, t) 177 | } 178 | | callptr -> fun(dst) { 179 | tp = ll_value_type(env, types, fn); 180 | ptp = ll_pointee_type(tp); 181 | rtp = ll_fun_retval(ptp); 182 | bind(dst, rtp) 183 | } 184 | | else -> fun(dst) [] // dunno what to do 185 | } 186 | }; 187 | // force it 188 | iter:ir2(irtoplevel:fn) { 189 | deep irpair: ll_value_type(env, types, 'var'(nm)); 190 | }; 191 | return types 192 | }} 193 | 194 | \pfcode{ 195 | function ll_module_types(mdl) { 196 | env = mkhash(); 197 | addglob(nm, tp) = { 198 | ohashput(env, %Sm<<("global-type: ", nm), tp) 199 | }; 200 | addfunret(nm, tp) = { 201 | ohashput(env, %Sm<<("function-ret-type: ", nm),tp) 202 | }; 203 | iter:ir2(irmodule:mdl) { 204 | deep irtoplevel { 205 | %function -> { 206 | addfunret(name, ret); 207 | addglob(name, 'function'(ret,@map [tp;nm] in args do tp)) 208 | } 209 | | global -> addglob(name, type) 210 | | eglobal -> addglob(name, type) 211 | } 212 | }; 213 | return env}} 214 | 215 | \pfcode{ 216 | function ll_propagate_types(mdl) { 217 | env = ll_module_types(mdl); 218 | types = mkhash(); 219 | iter:ir2(irmodule:mdl) { 220 | deep irtoplevel { 221 | %function -> { 222 | fntypes = ll_propagate_types_fun(env, node); 223 | ohashput(types, name, fntypes) 224 | } 225 | | else -> []}}; 226 | return [env;types] 227 | }} 228 | 229 | \pfcode{ 230 | function ll_annotate_geps_fun(env, types, src) { 231 | is_unknown(tp) = 232 | visit:ir2(irtype: tp) { 233 | once irtype { 234 | alias -> id === '*unknown*' 235 | | else -> []}}; 236 | 237 | visit:ir2(irtoplevel: src) { 238 | deep irpair: mk:node(e = e(nm)); 239 | deep irexpr { 240 | getelementptr -> fun(dst) { 241 | tp = ll_value_type(env, types, ptr); 242 | mk:node(ptrtp = [tp]); 243 | } 244 | | getelementptr_inbounds -> fun(dst) { 245 | tp = ll_value_type(env, types, ptr); 246 | mk:node(ptrtp = [tp]); 247 | } 248 | | phi -> fun(dst) { 249 | if (is_unknown(t)) { 250 | tp = ll_value_type(env, types, 'var'(dst)); 251 | if (tp) mk:node(t = tp) else node} 252 | else node} 253 | | else -> fun(dst) node 254 | }}} 255 | 256 | function ll_annotate_geps(envtypes, mdl) { 257 | <[env;types]> = envtypes; 258 | visit:ir2(irmodule:mdl) { 259 | deep irtoplevel { 260 | %function -> { 261 | fntypes = ohashget(types, name); 262 | ll_annotate_geps_fun(env, fntypes, node); 263 | } 264 | | else -> node}}}} 265 | 266 | 267 | %%%% 268 | -------------------------------------------------------------------------------- /backend/passmgr.hl: -------------------------------------------------------------------------------- 1 | function ir2_bodypass(mdl, fn) 2 | visit:ir2(irmodule: mdl) { 3 | once irtoplevel { 4 | %function -> if(body) { 5 | <[nannot;nbody]> = fn(body); 6 | mk:node(body = nbody, annotations = nannot::annotations) 7 | } else node 8 | | else -> node 9 | } 10 | } 11 | 12 | function ir2_functionpass_inner(fnc, fn) 13 | { 14 | bbs = mkhash(); regs = mkhash(); regbbs = mkhash(); 15 | retval = mkref([]); 16 | visit:ir2(irtoplevel: fnc) { 17 | deep irbblock { 18 | bblock -> iter [nm;e] in c do e(name, nm) 19 | }; 20 | once irexpr : forall fun(lbl, reg) { 21 | ohashput(regs, reg, node); 22 | ohashput(regbbs, reg, lbl); 23 | } 24 | }; 25 | iter:ir2(irtoplevel: fnc) { 26 | once irbblock { 27 | bblock -> ohashput(bbs, name, node) 28 | }; 29 | }; 30 | iter:ir2(irtoplevel: fnc) { 31 | deep irtoplevel { 32 | %function -> { 33 | retval := fn(body, bbs, regs, ret, va:args); 34 | } 35 | } 36 | }; 37 | return ^retval; 38 | } 39 | 40 | function ir2_functionpass(mdl, fn) 41 | visit:ir2(irmodule: mdl) { 42 | once irtoplevel { 43 | %function -> { rt = mk:node(body = ir2_functionpass_inner(node, fn)); 44 | return rt} 45 | | else -> node 46 | } 47 | } 48 | -------------------------------------------------------------------------------- /backend/refine.hl: -------------------------------------------------------------------------------- 1 | 2 | 3 | // Converting ir0 (LLVM "native" AST into ir2 - our own mini-LLVM) 4 | 5 | function ir0_ir2_bblock(bb) { 6 | dummy() = gensym(); //TODO: sequence 7 | checkdst(nm) = if(not(nm) || %string?(nm)) dummy() else nm; 8 | visit:ir0(irbblock: bb) { 9 | deep irbblock : { 10 | <[t]:c> = split(fun(x) match x with 'branch'(@v) -> true, code); 11 | 'bblock'(%Sm<<(name), map(cdr,c), cdr(t))}; 12 | deep irstmt { 13 | set -> 'set'(checkdst(nm), e) 14 | | setstring -> 'set'(checkdst(nm), 'string'(s)) 15 | | store -> 'set'(dummy(), node) 16 | | volatile_store -> 'set'(dummy(), node) 17 | | label -> 'set'(dummy(), 'void'()) 18 | | else -> 'branch'(@node) 19 | }; 20 | deep irexpr { 21 | getelementptr -> 'getelementptr'(ptr, idxs) 22 | | getelementptr_inbounds -> 'getelementptr_inbounds'(ptr, idxs) 23 | | else -> node 24 | }}} 25 | 26 | function %ir0->ir2(tl) 27 | return visit:ir0(irtoplevel: tl) { 28 | deep irtoplevel { 29 | %function -> 'function'(cc,name,ret,va,args,body,annotations) 30 | | global -> 'global'(%Sm<<(name), type, v) 31 | | eglobal -> 'eglobal'(%Sm<<(name), type) 32 | | else -> node 33 | }; 34 | once irbblock: ir0_ir2_bblock(node)} 35 | -------------------------------------------------------------------------------- /backend/ssa-ast.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \subsection{AST for the generic SSA DSL} 4 | 5 | \pfcode{ 6 | ast genssa { 7 | top is (*varident:allocas, code:c); 8 | code is (.*bblock:bs); 9 | bblock = 10 | b(labident:name, *oppair:ops, *labident:nexts); 11 | oppair is (varident:name, iop:op); 12 | iop = phi(varident:orig,*labident:prevs,*varident:vals) 13 | | load(varident:v) 14 | | store(varident:dst, varident:src) 15 | | remap(varident:v) 16 | | use(.*varident:ids) 17 | ; 18 | varident is id:v; 19 | labident is id:v; 20 | } 21 | } 22 | 23 | 24 | %%% 25 | %%% -------------------------------------------------------------------------------- /backend/ssa-fold-ast.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \pfcode{ 4 | ast genssa2 { 5 | top = f(globident:nm, type:ret, *argpair:args, code:body); 6 | code is (.*bblock:bs); 7 | argpair is (type:t, ident:name); 8 | bblock = 9 | b(labident:name, *oppair:ops, term:t); 10 | oppair is (varident:name, iop:op); 11 | iop = phi(.*phiarg:args) 12 | | select(expr:cnd, expr:t, expr:f) 13 | | call(*attr:a, iident:dst, .*expr:args) 14 | ; 15 | switchdst is (expr:v, labident:l); 16 | term = br(labident:dst) 17 | | brc(expr:c, labident:tr, labident:fl) 18 | | switch(expr:v, labident:d, .*switchdst:ns) 19 | | indirect(*any:orig, .*labident:dsts) 20 | | none() 21 | ; 22 | expr = var(varident:id) 23 | | glob(globident:id) 24 | | const(type:t, any:v) 25 | | other(type:t, any:v) 26 | ; 27 | phiarg = a(labident:src, expr:v); 28 | attr = constcall() | sideeffects() | intrinsic() | external(); 29 | varident is id:v; 30 | labident is id:v; 31 | }} 32 | 33 | %%%%%%%%% -------------------------------------------------------------------------------- /clike/apitst.cs: -------------------------------------------------------------------------------- 1 | using System; 2 | using Meta.Scripting; 3 | 4 | class ApiTest { 5 | 6 | public static void Main(string[] args) 7 | { 8 | // A generic MBase library initialisation 9 | Meta.Scripting.Runtime.iRuntime(); 10 | CLikeCore.InitDLL.init(); 11 | 12 | CLike.set_debuglevel(4); 13 | 14 | // Clike environment initialisation 15 | var env = CLike.init_module("mtest"); 16 | 17 | // Defining a familiar signature 18 | CLike.compile(env, "int32 printf(int8 *format, ...);"); 19 | 20 | // Not a C thing, actually - defining an MBase function that invokes C functions 21 | CLike.compile(env, "##function invoke_2(ptr,a,b) {(llvm_make_invoker(t_Int32,t_Int32,t_Int32))(ptr,a,b)}"); 22 | 23 | CLike.compile(env, "int32 adder_inner(int32 x, int32 y) { return x*y + x*x; }"); 24 | 25 | // And now finally a C function, which is going to be JITed immediately 26 | CLike.compile(env, "__stdcall int32 add(int32 x, int32 y) { printf(\"arg1=%d arg2=%d\\n\",x,y); return adder_inner(x,y); }"); 27 | 28 | // This pointer points to a JIT-compiled entry 29 | var ptr = CLike.getptr(env, "add"); 30 | 31 | // A generic MBase function invocation 32 | object res = 33 | Meta.Scripting.Runtime.apply(Meta.Scripting.Symbol.make("invoke_2"), 34 | new object[] { ptr, 22, 33 } ); 35 | 36 | // Displaying some results 37 | Console.WriteLine("ptr=" + ptr); 38 | Console.WriteLine("res=" + res); 39 | 40 | // Dumping LLVM bitcode file for a reference 41 | CLike.save(env, "out.bc"); 42 | } 43 | } -------------------------------------------------------------------------------- /clike/clike-api.hl: -------------------------------------------------------------------------------- 1 | 2 | mixed class Meta.Scripting.CLike { 3 | mbase public static object init_module(string mdname) 4 | { 5 | return [clike_global_env();llvm_init_module(mdname)] 6 | } 7 | 8 | mbase public static object set_debuglevel(int levl) 9 | { 10 | clike_debug_level := levl; 11 | return levl; 12 | } 13 | 14 | mbase public static object compile(object cenv, string code) 15 | { 16 | <[env;mdl]> = cenv; 17 | return clike_compile_string(mdl,env,code); 18 | } 19 | 20 | mbase public static object compileFile(object cenv, string fname) 21 | { 22 | <[env;mdl]> = cenv; 23 | return clike_compile_file(mdl, env, fname); 24 | } 25 | 26 | mbase public static object save(object cenv, string fname) 27 | { 28 | <[env;mdl]> = cenv; 29 | return llvm_save(mdl, fname); 30 | } 31 | mbase public static object getptr(object cenv, string glob) 32 | { 33 | <[env;mdl]> = cenv; 34 | return hashget(env, %S<<(" :refl: (",glob,")")); 35 | } 36 | } 37 | 38 | 39 | -------------------------------------------------------------------------------- /clike/clike-ast.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \section{ASTs definitions} 4 | 5 | \subsection{The source language (generated by a parser)} 6 | 7 | \fbox{\includegraphics[scale=0.4]{clike.pdf}} 8 | 9 | \pfcode{ 10 | ast clike { 11 | lltoplev = 12 | cfunc(pos:LOC, *llcallconv:cc, lltype:ret, topident:name, bool:va, 13 | *llfuncarg:args, llcode:body, .*any:annotations) 14 | | efunc(pos:LOC, *llcallconv:cc, lltype:ret, topident:name, bool:va, 15 | *llfuncarg:args, .*any:annotations) 16 | | typedef(pos:LOC, lltype:tp, topident:name) 17 | | global(pos:LOC, lltype:tp, llvarname:name, .*llconst:init) 18 | | eglobal(pos:LOC, lltype:tp, llvarname:name) 19 | | begin(.*lltoplev:es) 20 | 21 | // Should not appear after macro expansions 22 | | macroapp(ident:nm, .*llmacroarg:args) 23 | 24 | // For storing intermediate LLVM code: 25 | | xfunc(lltype:ret, topident:name, bool:va, . *llfuncarg:args) 26 | | xglobal(lltype:tp, topident:name) 27 | // Bypass entries 28 | | xxexpr(llexpr:e) 29 | | xxcode(llcode:c) 30 | ; 31 | 32 | topident is ident:v; // a dummy node 33 | 34 | llmacroarg = 35 | stmt(llcode:s) 36 | | top(lltoplev:t) 37 | | type(lltype:t) 38 | | verb(any:v) 39 | ; 40 | 41 | lltmacroarg = 42 | stmt(llcode:s) 43 | | expr(llexpr:s) 44 | | lvalue(lvalue:s) 45 | | var(ident:v) 46 | | type(lltype:t) 47 | | verb(any:v) 48 | ; 49 | 50 | llvarname = v(ident:name) 51 | // Should not be present after macro expansion: 52 | | p(lltypepatch:p) 53 | ; 54 | 55 | llfuncarg is (lltype:tp, llvarname:name); 56 | 57 | llcode = 58 | begin(. *llcode:es) 59 | | label(pos:LOC, ident:lbl) 60 | | vardef(lltype:tp, llvarname:name) 61 | | set(pos:LOC, lvalue:l, llexpr:e) 62 | | expr(llexpr:e) 63 | | return(pos:LOC,llexpr:e) 64 | | vreturn(pos:LOC) 65 | | goto(pos:LOC, ident:lbl) 66 | | for(pos:LOC, *llcode:init, llexpr:cnd, llcode:step, llcode:body) 67 | | while(pos:LOC, llexpr:cnd, llcode:body) 68 | | do(pos:LOC, llcode:body, llexpr:cnd) 69 | | switch(pos:LOC, llexpr:e, *llswitchopt:opts, *llcode:dflt) 70 | | if3(pos:LOC, llexpr:e, llcode:tr, llcode:fl) 71 | | if2(pos:LOC, llexpr:e, llcode:tr) 72 | | break(pos:LOC) 73 | | nop() 74 | 75 | // Valid till the type propagation pass only 76 | | varinit(ident:l, llexpr:r) 77 | 78 | // Top level things lifting, should be eliminated right after typing 79 | // pass (as it may be a result of a macro application) 80 | | toplift(any:t) 81 | 82 | // A temporary node for clike2 translation only, should never be generated 83 | | passexpr(llexpr:e) 84 | | passtype(lltype:e) 85 | | passlvalue(lvalue:e) 86 | 87 | // Should not appear after macro expansions 88 | | macroapp(ident:nm, .*llmacroarg:args) 89 | | manyvardefs(lltype:tp, .*llvardefpair:vars) 90 | | protofor(pos:LOC, *llcode:init, *llexpr:cnds, *llexpr:steps, llcode:body) 91 | ; 92 | 93 | llvardefpair = s(llvarname:nm) 94 | | d(llvarname:nm, llexpr:ini) 95 | ; 96 | 97 | llswitchopt is (llconst: value, llcode:action); 98 | 99 | llexpr = 100 | inblock(pos:LOC, llcode:c, llexpr:r) 101 | 102 | | intrinsic(ident:fn, .*llexpr:args) 103 | | call(pos:LOC, ident:id, .*llexpr:args) 104 | | callptr(pos:LOC, lvalue:fn, .*llexpr:args) 105 | | stdcallpfx(llexpr:e) 106 | | bin(pos:LOC, ident:op, llexpr:l, llexpr:r) 107 | 108 | | compop(pos:LOC, ident:op, llexpr:l, llexpr:r) 109 | | tri(llexpr:cnd, llexpr:tr, llexpr:fl) 110 | 111 | | un(ident:op, llexpr:e) 112 | | typecast(lltype:t, llexpr:e) 113 | | bitcast(lltype:t, llexpr:e) 114 | | pre(ident:op, lvalue:v, .*lltype:vtyp) 115 | | post(ident:op, lvalue:v, .*lltype:vtyp) 116 | 117 | | modop(pos:LOC, ident:op, lvalue:l, llexpr:r) 118 | 119 | | eset(pos:LOC, lvalue:v, llexpr:e) 120 | | const(llconst:c) 121 | | globstring(string:s) 122 | 123 | | logand(pos:LOC, .*llexpr:es) 124 | | logor(pos:LOC, .*llexpr:es) 125 | 126 | | var(ident:nm) 127 | | arg(ident:nm) 128 | | glob(ident:nm) 129 | | globfun(ident:nm) 130 | 131 | | array(lvalue:ar, .*llexpr:idxs) 132 | | ref(lvalue:e) 133 | | deref(llexpr:e) 134 | | getelt(lvalue:e, ident:fldnm) 135 | | sizeof(lltype:t) 136 | 137 | // Special dual-stage macro expansion (propagation + post-propagation) 138 | | typedmacro(ident:nm, .*lltmacroarg:args) 139 | 140 | // Inline assembly or whatever else 141 | | inline(lltype:ret,*llexpr:args, any:code) 142 | 143 | // Should not appear after macro expansions 144 | | macroapp(ident:nm, .*llmacroarg:args) 145 | | protoinblock(pos:LOC, .*llcode:c) 146 | | commaexprs(pos:LOC, .*llexpr:es) 147 | ; 148 | 149 | lvalue = 150 | var(ident:nm) 151 | | glob(ident:nm) 152 | | globfun(ident:nm) 153 | | arg(ident:nm) 154 | | array(lvalue:ar, .*llexpr:idxs) 155 | | deref(llexpr:e) 156 | | getelt(lvalue:e, ident:fldnm) 157 | | macroapp(ident:nm, .*llmacroarg:args) 158 | ; 159 | 160 | llconst = 161 | null() 162 | | integer(ident:itype, int:v) 163 | | real(ident:rtype, real:v) 164 | | string(string:s) 165 | | constarray(. *llconst:elts) 166 | | conststruct(lltype:t, .*llcstrelt:elts) 167 | | zero(lltype:t) 168 | | var(ident:nm) 169 | | ptr(llconst:c) 170 | ; 171 | 172 | llcstrelt is (ident:fld, llconst:v); 173 | llstrelt is (ident:fld, lltype:t); 174 | llmacrostrelt is (lltype:t, llvarname:fld); 175 | 176 | lltypepatch = 177 | | ptr(lltypepatch:t) 178 | | fun(lltypepatch:ret, bool:va, .*lltype:args) 179 | | array(lltypepatch:t, *llconstexpr:dims) 180 | | v(ident:nm) 181 | ; 182 | 183 | lltype = 184 | integer(ident:itype) 185 | | real(ident:rtype) 186 | | alias(ident:x) 187 | | struct(*ident:nm, .*llstrelt:ts) 188 | | structalias(ident:nm) 189 | | structref(ident:nm) 190 | | ptr(lltype:t,.*aspace:spc) 191 | | fun(lltype:ret, bool:va, .*lltype:args) 192 | | array(lltype:t, *llconstexpr:dims, .*aspace:spc) 193 | | string() 194 | | void() 195 | 196 | // Qualified type 197 | | qual(qualifiers:c, lltype:t) 198 | | attr(attribute:a, lltype:t) // source level, to be translated to qual 199 | 200 | // Invalid after macro expansion 201 | | macrostruct(*ident:nm, .*llmacrostrelt:ts) 202 | | macroapp(ident:nm, .*llmacroarg:args) 203 | | typedmacro(ident:nm, .*lltmacroarg:args) 204 | 205 | // Intermediate, used for transforms 206 | | null() 207 | | bool() 208 | | arg(lltype:t) 209 | | nop() 210 | ; 211 | llconstexpr is (.any:e); 212 | } 213 | } 214 | 215 | \phcode{%draw:ast:graph(clike,"./doc/clike.dot")} 216 | 217 | 218 | \subsection{Same language with all the expressions annotated with their types} 219 | 220 | \pfcode{ 221 | ast clike2 : clike ( llexpr -> lloexpr, lvalue -> olvalue, 222 | llvarname -> ollvarname, 223 | llconstexpr -> ollconstexpr) { 224 | llexpr is (lltype:t , . lloexpr:e); 225 | lvalue is (lltype:t , . olvalue:e); 226 | llconstexpr is any:v; 227 | } 228 | } 229 | 230 | 231 | \subsection{A first intermediate language} 232 | 233 | This intermediate language is already mostly LLVM, but expressions 234 | are allowed to be nested and types annotations are still present. 235 | 236 | \pfcode{ 237 | ast clike3 { 238 | llstmt2 = 239 | set(ident:nm, llexpr2:e) 240 | | setstring(ident:nm, string:s) 241 | | ret(llexpr2:value) 242 | | vret() 243 | | br(llexpr2:cnd, irlabel:tr, irlabel:fl) 244 | | br_label(ident:nm) 245 | | switch(llexpr2:value, irlabel:els, *irswitchdst:cases) 246 | | store(llexpr1:ptr, llexpr2:e) 247 | | storevar(ident:ptr, llexpr2:e) 248 | | label(ident:nm) 249 | | begin(.*llstmt2:es) 250 | | nop() 251 | // An intermediate instruction, must be removed before compilation 252 | | break() 253 | ; 254 | 255 | irswitchdst is ( llval:value, irlabel:dst ); 256 | 257 | llexpr2 is (lltype:t,.llexpr1:e); 258 | 259 | llexpr1 = 260 | binary(irbinop:op, llexpr2:l, llexpr2:r) 261 | | extractelement(int:n, llexpr2:v, llexpr2:idx) 262 | | insertelement(int:n, irtype:t, llexpr2:v, llexpr2:elt, llexpr2:idx) 263 | | shufflevector(int:n1, llexpr2:val1, int:n1, llexpr2:val2, llexpr2:mask) 264 | | extractvalue(iraggtype:t, llexpr2:v, llexpr2:idx) 265 | | insertvalue(llexpr2:v, irtype:tv, llexpr2:elt, llexpr2:idx) 266 | | alloca(irtype:t,.*ident:varname) 267 | | load(llexpr2:ptr) 268 | | loadvar(ident:id) // shortcut 269 | | getelementptr(llexpr2:ptr, . *llexpr2:idxs) 270 | | getelementptr_inbounds(llexpr2:ptr, . *llexpr2:idxs) 271 | | convop(irconvop:op, llexpr2:v, irtype:t) 272 | | icmp(iricond:vcond, llexpr2:lhs, llexpr2:rhs) 273 | | fcmp(irfcond:vcond, llexpr2:lhs, llexpr2:rhs) 274 | | phi(irtype:t, .*irphi:dsts) 275 | | select(llexpr2:vif, llexpr2:vthen, llexpr2:velse) 276 | 277 | | intrinsic(ident:fn, .*llexpr2:args) 278 | 279 | | call(ident:fn, .*llexpr2:args) 280 | | callptr(llexpr2:fn, .*llexpr2:args) 281 | | callptrstd(llexpr2:fn, .*llexpr2:args) 282 | | ptr(llexpr2:src, irtype:dst) 283 | | liftstatements(llstmt2:s, llexpr2:e) 284 | | val(llval:v) 285 | | stringtmp(string:s) 286 | | inline(irtype:t, *llexpr2:args, any:code) 287 | ; 288 | 289 | llval = 290 | false() 291 | | true() 292 | | null(irtype:t) 293 | | integer(int:v, .*ident:itp) 294 | | float(float:v, .*ident:ftp) 295 | | struct(ident:nm, . *irstructel:elts) 296 | | array(irtype:t, . *llval:elts) 297 | | vector(. *llval:elts) 298 | | zero(irtype:t) 299 | | undef(irtype:t) 300 | | string(string:s) 301 | | blockaddress(irfunction:fn, irblock:blk) 302 | | var(ident:nm) 303 | | global(ident:nm) 304 | | globalfun(ident:nm) 305 | | sizeof(irtype:t) 306 | ; 307 | 308 | irtype = 309 | integer(ident:type) 310 | | float(ident:ftype) 311 | | label() 312 | | void() 313 | | array(*int:dims, irtype:t, .*aspace:spc) 314 | | %function(irtype:ret, .*irtype:args) 315 | | varfunction(irtype:ret, .*irtype:args) 316 | | struct(ident:nm, . *irtype:elts) 317 | | structref(ident:nm) 318 | | packed(ident:nm, . *irtype:elts) 319 | | pointer(irtype:t, .*aspace:spc) 320 | | vector(int:n, irtype:t) 321 | | alias(ident:id) 322 | ; 323 | } 324 | } 325 | 326 | 327 | 328 | %%%%%%%%%%%% 329 | 330 | -------------------------------------------------------------------------------- /clike/clike-cc-standalone.hl: -------------------------------------------------------------------------------- 1 | define CLikeCore = 'CLikeSCore'; 2 | #(force-class-flush) 3 | ------------------------ 4 | 5 | include "./clike-cc.hl"; 6 | 7 | -------------------------------------------------------------------------------- /clike/clike-cc.hl: -------------------------------------------------------------------------------- 1 | ///// A simple cc-like standalone compiler front-end 2 | #(ctime `(usedll ,(alet x (shashget (getfuncenv) 'CLikeCore) 3 | (if x x 'CLikeCore)))) 4 | 5 | -------------------------- 6 | 7 | 8 | function clike_compile_files(mdname, fls) 9 | { 10 | nollvm = ^clike_no_llvm; 11 | mdl = llvm_init_module(mdname); 12 | if(nollvm) clike_outfile_v := %io-open-write(%S<<(mdname,".x")); 13 | env = clike_global_env(); 14 | %read-int-eval('define'('clike-current-env',#`(quote ,env))); 15 | %read-int-eval('define'('clike-current-llvm-env',#`(quote ,mdl))); 16 | iter fls do { 17 | println(%S<<("Compiling: ",fls)); 18 | match fls with 19 | c(fn) -> clike_compile_file(mdl,env,fn) 20 | | x(fn) -> clike_bypass_file(mdl,env,fn) 21 | }; 22 | if(not(nollvm)) llvm_save(mdl, %S<<(mdname,".o")) else { 23 | llvm_save(mdl, mdname); 24 | %io-wclose(^clike_outfile_v); 25 | }; 26 | println("Done."); 27 | } 28 | 29 | 30 | function main() 31 | collector(fadd,fget) { 32 | %read-int-eval(#'(n.module clikeccrepl dll)); 33 | mname = mkref("test"); 34 | do loop(a = %a->l( %*CMDLINE* )) { 35 | match a with 36 | ["/out";mdlname;@rest] -> {mname := mdlname;loop(rest)} 37 | | ["/d";dllname;@rest] -> {%read-compile-eval('usedll'(%Sm<<(dllname))); 38 | loop(rest);} 39 | | ["/o+";@rest] -> { %llvm-optimise := true; loop(rest)} 40 | | ["/o-";@rest] -> { %llvm-optimise := []; loop(rest)} 41 | | ["/dbg";levl;@rest] -> {clike_debug_level := %S->N(levl); loop(rest)} 42 | | ["/s";hlfile;@rest] -> {%read-compile-eval('hlevl-file'(hlfile)); loop(rest)} 43 | | ["/a";alfile;@rest] -> {%read-compile-eval('include'(alfile)); loop(rest)} 44 | | ["/c";@rest] -> {llvm_no_engine := true;loop(rest)} 45 | | ["/i";@rest] -> {clike_no_llvm := true;loop(rest)} 46 | | ["/x";fname;@rest] -> {fadd('x'(fname));loop(rest)} 47 | | [srcfile;@rest] -> {fadd('c'(srcfile));loop(rest)} 48 | | [] -> { 49 | fls = fget(); 50 | if(not(fls)) { 51 | iter(println, 52 | ["Usage: clikecc [option...] file.c..."; 53 | "Options:"; 54 | " /out : save bitcode to a given module"; 55 | " /d : load a given MBase dll"; 56 | " /s : load a given PFront source file"; 57 | " /a : load a given MBase source file"; 58 | " /x : compile in an intermediate LLVM code"; 59 | " /i : save an output in an intermediate format"; 60 | " /c : disable JIT engine and reflection"; 61 | " /o+ : enable LLVM optimisation"; 62 | " /o- : disable LLVM optimisation"; 63 | " /dbg : enable debugging output (1-8)"]); 64 | quit(); 65 | } 66 | else clike_compile_files(^mname,fls); 67 | } 68 | } 69 | } 70 | 71 | -------------------------------------------------------------------------------- /clike/clike-compiler-top.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \section{A toplevel compiler} 4 | 5 | 6 | A compilation frontend for function bodies: binds all the passes together 7 | Pipeline is following: 8 | types propagation $\to$ tree compilation $\to$ 9 | values redefs elimination $\to$ tree flattening $\to$ 10 | values redefs elimination $\to$ metadata elimination $\to$ 11 | basic blocks extraction 12 | 13 | \pfcode{ 14 | function clike_compile_code(toploop, env, code, crettype, rettype) 15 | { 16 | clike_dbg(1, "S0:",code); 17 | 18 | step1 = clike_types(env, code, toploop, crettype); 19 | clike_dbg(1,"S1:",step1); 20 | step2 = clike_precompile(env, step1); clike_dbg(2,"S2:",step2); 21 | step3 = clike_fix_sets(step2); clike_dbg(3,"S3:",step3); 22 | step3_1 = clike_lift_1(step3); clike_dbg(4,"S3_1:",step3_1); 23 | step4 = clike_fix_sets(step3_1); clike_dbg(5,"S4:",step4); 24 | step5 = clike_cleanup(step4); 25 | step6 = clike_basicblocks(rettype,step5); clike_dbg(6,"S6:",step6); 26 | 27 | return step6; 28 | } 29 | } 30 | 31 | 32 | A compilation frontend for toplevel definitions. It is possible that a new toplevel expression is lifted, so an external top loop function should be provided. 33 | 34 | \pfcode{ 35 | function clike_compile(etoploop, topenv, top) 36 | collector(topsadd, topsget) 37 | { 38 | toploop(env, t) = { iter i in etoploop(t) do topsadd(i) }; 39 | rcode = 40 | visit:clike(lltoplev: top) 41 | { 42 | once topident : clike_env_name_mangle(topenv:[], node); 43 | once llvarname { v -> mk:node(name=clike_env_name_mangle(topenv:[], name)) 44 | | else -> node }; 45 | once llcode : forall node; // stop here, do not touch llvarnames inside 46 | deep lltoplev { 47 | begin -> map append es do es 48 | | typedef -> { clike_env_defalias(topenv, name, tp); 49 | clike_dbg(0,"Top:",#`(typedef: ,tp ,name)); 50 | ['comment'('clike'(node))]} 51 | | xfunc -> {clike_env_deffunction(topenv, name, va, ret, args); []} 52 | | xglobal -> {clike_env_defglobal(topenv, name, tp); []} 53 | | efunc -> {clike_env_deffunction(topenv, name, va, ret, args); 54 | clike_dbg(0,"Top:",#`(efunc: ,name ,ret ,@args ,va)); 55 | env = topenv:mkhash(); 56 | cc1 = if(cc) ['stdcall'] else []; 57 | ['comment'('clike'('xfunc'(ret,name, va,@args))); 58 | 'function'(cc1,name, clike_c_type(env, clike_env_unitype(env, ret)), va, 59 | map [tp;'v'(nm)] in args do { 60 | [clike_c_type(env,clike_env_unitype(env, tp)); nm] 61 | },[])] 62 | } 63 | | global -> {clike_env_defglobal(topenv, cadr(name), tp); 64 | env = topenv:mkhash(); 65 | gtp = clike_ca_type(env,clike_env_unitype(env, tp)); 66 | clike_dbg(0,"Top:",#`(global: ,gtp ,name ,init)); 67 | return ['global'( %S<<(cadr(name)), 68 | gtp, 69 | if(init) cadr(clike_c_const(env, car(init), 'ptr'(clike_env_unitype(env, tp)))) 70 | else 'zero'(gtp) 71 | )] 72 | } 73 | | eglobal -> {clike_env_defglobal(topenv, cadr(name), tp); 74 | clike_dbg(0,"Top:",#`(global: ,tp ,name)); 75 | env = topenv:mkhash(); 76 | return ['comment'('clike'('xglobal'(tp, cadr(name)))); 77 | 'eglobal'( %S<<(cadr(name)), 78 | clike_ca_type(env,clike_env_unitype(env, tp)) )] 79 | } 80 | | cfunc -> { 81 | env = clike_local_env(topenv, args); 82 | clike_dbg(0,"Top:",#`(cfunc: ,name ,cc ,ret ,@args)); 83 | clike_env_deffunction(topenv, name, va, ret, args); 84 | rett = clike_env_unitype(env, ret); 85 | cbody = clike_compile_code(toploop,env,body, 86 | rett, 87 | clike_c_type(env,rett)); 88 | clike_env_savebody(topenv, name, body, cbody); 89 | cc1 = {match cc with 90 | ['llvm'()] -> [] 91 | | else -> cc}; 92 | ['comment'('clike'('xfunc'(ret,name,va,@args))); 93 | 'function'(cc1, name, clike_c_type(env,rett), va, 94 | map [tp;'v'(nm)] in args do { 95 | [clike_c_type(env,clike_env_unitype(env, tp)); nm] 96 | }, 97 | cbody,@annotations)] 98 | } 99 | | else -> ccerror('CLIKE:NOT-IMPLEMENTED-YET'(node)) 100 | } 101 | }; 102 | iter rcode do topsadd(rcode); 103 | return topsget(); 104 | } 105 | } 106 | 107 | \pfcode{ 108 | function clike_to_llvm_inner(env, cltops) 109 | { 110 | cl1 = map t in cltops do clike_expand_macros_top(env, clike_expand_core(t)); 111 | cl2 = map append t in cl1 do clike_compile(fun(t) {clike_to_llvm_inner(env, [t])}, env, t); 112 | return cl2; 113 | } 114 | 115 | 116 | function clike_to_llvm(topenv, tops) 117 | { 118 | try { 119 | try clike_to_llvm_inner(topenv, tops) 120 | catch (t_MBaseException e) { 121 | println("Compiler error:"); 122 | println(mbaseerror(e)); 123 | println(%->s(e)); 124 | return [] 125 | }} catch (t_Exception e) { 126 | println(%->s(e)); 127 | return [] 128 | } 129 | } 130 | } -------------------------------------------------------------------------------- /clike/clike-embed.hl: -------------------------------------------------------------------------------- 1 | #(usedll CLikeCore) 2 | 3 | ------------------- 4 | 5 | #(macro __cl_define_dll (dllname) 6 | (let* ((mdl (llvm_init_module dllname)) 7 | (env (clike_global_env)) 8 | (dllfile (S<< dllname ".dll"))) 9 | =pf: { 10 | %read-int-eval('define'('clike-current-env',#`(quote ,env))); 11 | %read-int-eval('define'('clike-current-llvm-env',#`(quote ,mdl))); 12 | %read-int-eval('define'(%Sm<<("Module_",dllname), 13 | #`(quote (,mdl ,env ,dllfile)))) 14 | } 15 | `(top-begin ) 16 | )) 17 | 18 | #(macro __cl_save_dll (envname) 19 | (format (read-int-eval (Sm<< "Module_" envname)) 20 | (mdl env dllname) 21 | (llvm_save (S<< envname ".bc")))) 22 | 23 | #(macro __cl_embed_emit_simple (envname topcode) 24 | (format (read-int-eval (Sm<< "Module_" envname)) 25 | (mdl env dllname) 26 | (foreach (t topcode) 27 | (clike_compile_ast mdl env (list t)))) 28 | `(top-begin )) 29 | 30 | #(macro __cl_embed_emit_wrapper (envname fname rtype argtypes code) 31 | (format (read-int-eval (Sm<< "Module_" envname)) 32 | (mdl env dllname) 33 | (clike_compile_ast mdl env (list code)) 34 | (let* ((cname (gensym)) 35 | (invname (gensym)) 36 | (argnms (foreach-map-count (a argtypes i) 37 | (Sm<< "aa" i))) 38 | (wclass `(native (classname ,cname) 39 | (import ,dllname 40 | ,(S<< fname) 41 | ,@argtypes)))) 42 | `(top-begin 43 | ,wclass 44 | ; Override the definition in compilation-time mode 45 | ; (force-class-flush) 46 | ; (define ,invname (llvm_make_invoker ,rtype ,@argtypes)) 47 | (force-class-flush) 48 | (ctimex 49 | (define ,fname (fun ,argnms 50 | ;(,invname (clike_get_ptr ,(S<< fname)) 51 | ; ,@argnms) 52 | (invoke_native_func (clike_get_ptr ,(S<< fname)) 53 | (list ,@argnms)) 54 | ))))))) 55 | 56 | --------------------------------------- 57 | 58 | syntax in top, start (pfclike): '".TC" "(" [qident]:nm ")" ":" [cltop]:t' 59 | { 60 | #`(expr (lisp (__cl_embed_emit_simple ,nm (,t)))) 61 | } 62 | 63 | syntax in top, start (pfclike): '".TCDEF" "(" [qident]:nm ")" ":" [ioptop]:t' 64 | + { 65 | ioptop := 66 | [ioptype]:ret [clqident]:name "(" ecslist<[ioparg],",">:args ")" 67 | "{" eslist<[clcode]>:es "}" => iopfun(ret,name,args,es); 68 | ioparg := [ioptype]:t [clqident]:name => arg(t,name); 69 | ioptype := { "intptr_t" => intptr() } 70 | / { "int" => int() } 71 | / { "float" => float() } 72 | ; 73 | } 74 | { 75 | // TODO 76 | [] 77 | } 78 | -------------------------------------------------------------------------------- /clike/clike-env.hl: -------------------------------------------------------------------------------- 1 | //// Environments are implemented in a simple way, using huge hash tables 2 | //// It should not be a problem, as normally CLike programs should be small. 3 | 4 | //// Makes an empty global environment 5 | function clike_global_env() 6 | { 7 | e = mkhash(); 8 | e /! " :macros" <- clike_default_mcenv; 9 | return e; 10 | } 11 | 12 | 13 | //// Finds a global name in an environment 14 | function clike_env_name_resolve(env, name) 15 | { 16 | = env; 17 | resolver = genv /@ " :name resolver: "; 18 | if(resolver) resolver(name) else name 19 | } 20 | 21 | //// Generates a mangled name, if a mangler is defined 22 | function clike_env_name_mangle(env, name) 23 | { 24 | = env; 25 | m = genv /@ " :name mangler: "; 26 | if(m) m(name) else name 27 | } 28 | 29 | //// Adds a new resolver function to the environment, pushes the 30 | //// previous one into a stack. 31 | function clike_push_resolver(env, fn) 32 | { 33 | = env; 34 | oldresolver = genv /@ " :name resolver: "; 35 | genv/! " :name resolver stack: " <- 36 | (oldresolver:(genv/@" :name resolver stack: ")); 37 | genv /! " :name resolver: " <- fn; 38 | } 39 | 40 | //// Adds a new mangler function to the environment, pushes the 41 | //// previous one into a stack 42 | function clike_push_mangler(env, fn) 43 | { 44 | = env; 45 | oldresolver = genv /@ " :name mangler: "; 46 | genv/! " :name mangler stack: " <- 47 | (oldresolver:(genv/@" :name mangler stack: ")); 48 | genv /! " :name mangler: " <- fn; 49 | } 50 | 51 | //// Pops a previous resolver from a stack 52 | function clike_pop_resolver(env) 53 | { 54 | = env; 55 | = genv/@ " :name resolver stack: "; 56 | genv/!" :name resolver stack: "<-tl; 57 | genv /! " :name resolver: " <- hd; 58 | } 59 | 60 | //// Pops a previous mangler function from a stack 61 | function clike_pop_mangler(env) 62 | { 63 | = env; 64 | = genv/@ " :name mangler stack: "; 65 | genv/!" :name mangler stack: "<-tl; 66 | genv /! " :name mangler: " <- hd; 67 | } 68 | 69 | 70 | //// Makes a local environment pre-filled with function argument types 71 | function clike_local_env(topenv, args) 72 | { 73 | newenv = mkhash(); 74 | env = topenv : newenv; 75 | iter args do { 76 | <[tp;'v'(nm)]> = args; 77 | newenv /! nm <- 'arg'(clike_env_unitype(env, tp)); 78 | }; 79 | return env; 80 | } 81 | 82 | //// A helper function: gets a function return type 83 | function clike_functype(ftyp) 84 | visit:clike(lltype:ftyp) { 85 | once lltype { fun -> ret : va : args 86 | | else -> ccerror('CLIKE:NOT-A-FUNCTION-TYPE'(ftyp))}} 87 | 88 | //// A helper function: gets a return type from a function pointer 89 | function clike_funcptrtype(ftyp) 90 | visit:clike(lltype:ftyp) { 91 | once lltype { ptr -> clike_functype(t) 92 | | else -> ccerror('CLIKE:NOT-A-POINTER-TYPE'(ftyp))}} 93 | 94 | //// Gets a return type for a given function name (which can be a local 95 | //// variable, an argument or a global variable - in this case it is 96 | //// treated as a pointer to a function) 97 | function clike_env_funcretargtypes(env, id) 98 | { 99 | = env; 100 | chk0 = l/@id; // check if it is a var or an arg 101 | if(chk0) clike_funcptrtype(cadr(chk0)) 102 | else { 103 | chk1 = t/@id; // check if it is a global pointer or a function declaration 104 | match chk1 with 105 | global(ptrtyp) -> clike_funcptrtype(ptrtyp) 106 | | %function(ftyp) -> clike_functype(ftyp) 107 | | else -> ccerror('CLIKE:UNDEFINED-FUNCTION'(id)) 108 | } 109 | } 110 | 111 | //// Checks if an id is an argument, if so - returns its type 112 | function clike_env_argtype(env, id) 113 | { 114 | = env; 115 | chk0 = l/@id; 116 | match chk0 with 117 | arg(t) -> t 118 | | else -> [] 119 | } 120 | 121 | //// Checks if an id is a global variable, if so - returns its type 122 | function clike_env_globtype(env, id) 123 | { 124 | = env; 125 | chk0 = t/@id; 126 | match chk0 with 127 | global(t) -> t 128 | | else -> [] 129 | } 130 | 131 | function clike_env_globfunctype(env, id) 132 | { 133 | = env; 134 | chk0 = t/@id; 135 | match chk0 with 136 | %function(t) -> t 137 | | else -> [] 138 | } 139 | 140 | //// Resolves a type alias 141 | function clike_env_getalias(env, id) 142 | { 143 | = env; 144 | chk0 = t/@id; 145 | match chk0 with 146 | alias(t) -> t 147 | | else -> ccerror('CLIKE:UNDEFINED-TYPE-ALIAS'(id)) 148 | } 149 | 150 | function clike_env_checkstructalias(env, nm0, node) 151 | if(nm0) { 152 | nm=car(nm0); 153 | = env; 154 | id = %S<<("struct: ",nm); 155 | chk0 = t/@ id; 156 | match chk0 with 157 | struct(@_) -> [] 158 | | else -> {t/!id <- node} 159 | } 160 | 161 | function clike_env_checkstructaliasexist(env, nm0) 162 | if(nm0) { 163 | nm=car(nm0); 164 | = env; 165 | id = %S<<("struct: ",nm); 166 | chk0 = t/@ id; 167 | match chk0 with 168 | struct(@_) -> true 169 | | else -> [] 170 | } 171 | 172 | function clike_env_getstructalias(env, id) 173 | { 174 | = env; 175 | chk0 = t/@ %S<<("struct: ",id); 176 | match chk0 with 177 | struct(@_) -> chk0 178 | | else -> 'structref'(id) 179 | } 180 | 181 | //// A helper function which expands all the type aliases present in the current 182 | //// environment 183 | function clike_env_unitype(env, tp) 184 | do loop(t = tp) 185 | visit:clike(lltype: t) { 186 | deep lltype { 187 | alias -> loop(clike_env_getalias(env, x)) 188 | | structalias -> loop(clike_env_getstructalias(env, nm)) 189 | | struct -> {clike_env_checkstructalias(env, nm, node); node} 190 | | else -> node 191 | }} 192 | 193 | //// A global environment management function: defines a type alias 194 | function clike_env_defalias(env, name, tp) 195 | { 196 | r = clike_env_unitype(env:mkhash(), tp); 197 | env /! name <- 'alias'(r);[]} 198 | 199 | //// A global environment management function: defines a function signature 200 | function clike_env_deffunction(env, name, va, ret, args) 201 | { 202 | denv = env:mkhash(); // dummy environment 203 | rret = clike_env_unitype(denv, ret); 204 | rargs = map a in args do { = a; clike_env_unitype(denv, tp)}; 205 | env /! name <- 'function'('fun'(rret,va,@rargs)); [] 206 | } 207 | 208 | //// A global environment management function: support for a compilation-time 209 | //// reflection. 210 | function clike_env_savebody(topenv, name, body, cbody) 211 | { 212 | topenv /! %S<<(" :defn: (",name,")") <- [body;cbody]; 213 | } 214 | 215 | //// A global environment management function: defines a global variable type 216 | function clike_env_defglobal(env, name, tp) 217 | { 218 | denv = env:mkhash(); // dummy environment 219 | rtp = clike_env_unitype(denv, tp); 220 | env /! name <- 'global'(rtp); [] 221 | } 222 | 223 | function clike_env_gettypingrules(env, nm) 224 | { 225 | = env; mcenv = genv /@ " :macros"; 226 | return mcenv /@ %S<<(" :typrules: ",nm); 227 | } 228 | 229 | function clike_env_gettypedexpander(env, nm) 230 | { 231 | = env; mcenv = genv /@ " :macros"; 232 | return mcenv /@ %S<<(" :typexpander: ",nm); 233 | } 234 | 235 | function clike_dbg(l,a, msg) 236 | if((^clike_debug_level)>l) println(%S<<(a," ",msg)) 237 | -------------------------------------------------------------------------------- /clike/clike-expand.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \section{Initial expansion pass} 4 | 5 | This is the first pass to be executed over a just parsed AST. Several different 6 | things are done on this level. Firstly, clike macro applications are 7 | partially expanded (but not the typed macros --- they'll be expanded in a type 8 | propagation pass). Secondly, a number of the initial AST oddities (introduced 9 | entirely for a sake of parsing simplicity) are 10 | substituted with a cleaner code. 11 | 12 | We're getting rid of the ``string'' type here 13 | (the one we've introduced for string literals), structs and function 14 | declarations are simplified, comma--blocks are expanded into a more fundamental 15 | form, variable declaration initialisers are separated from the declarations, 16 | and {\tt for} is simplified from initial {\tt protofor} nodes. Standalone expressions are also translated into phoney {\tt set}s. 17 | 18 | \pfcode{ 19 | ///\commentbox{Applies a macro, if it is valid, and then re-enters into the macro expansion loop.}\\ 20 | function clike_apply_macro(env, nm, args, reenter) 21 | { 22 | mcenv = env /@ " :macros"; 23 | if(not(mcenv)) ccerror('CLIKE:MACRO-ENV-UNDEFINED'(nm)); 24 | mc = mcenv /@ nm; 25 | if(not(mc)) ccerror('CLIKE:MACRO-UNDEFINED'(nm)); 26 | reenter(env, mc(env,args)); 27 | } 28 | 29 | ///\commentbox{Expand all the macros inside an expression}\\ 30 | function clike_expand_macros_expr(env, tl) 31 | visit:clike(llexpr: tl) { 32 | deep llexpr { 33 | macroapp -> clike_apply_macro(env, nm, args, clike_expand_macros_expr) 34 | | else -> node 35 | }; 36 | once lltype : forall clike_expand_macros_type(env, node); 37 | once llcode : forall clike_expand_macros_code(env, node); 38 | } 39 | 40 | ///\commentbox{Expands all the macros inside a statement}\\ 41 | function clike_expand_macros_code(env, tl) 42 | visit:clike(llcode: tl) { 43 | deep llcode { 44 | macroapp -> clike_apply_macro(env, nm, args, clike_expand_macros_code) 45 | | else -> node 46 | }; 47 | once lltype : forall clike_expand_macros_type(env, node); 48 | once llexpr : forall clike_expand_macros_expr(env, node); 49 | } 50 | 51 | ///\commentbox{A user--defined macros expansion pass. Should be performed right after the core macros expansion pass (which means that user-defined macros should not construct core macros).}\\ 52 | function clike_expand_macros_top(env, tl) 53 | visit:clike(lltoplev: tl) { 54 | deep lltoplev { 55 | macroapp -> clike_apply_macro(env, nm, args, clike_expand_macros_top) 56 | | else -> node 57 | }; 58 | once lltype : forall clike_expand_macros_type(env, node); 59 | once llcode : forall clike_expand_macros_code(env, node); 60 | } 61 | 62 | ///\commentbox{A user--defined macros expansion pass. Should be performed right after the core macros expansion pass (which means that user-defined macros should not construct core macros).}\\ 63 | function clike_expand_macros_type(env, tp) 64 | visit:clike(lltype: tp) { 65 | deep lltype { 66 | macroapp -> clike_apply_macro(env, nm, args, clike_expand_macros_top) 67 | | else -> node 68 | }; 69 | once llexpr : forall clike_expand_macros_expr(env, node); 70 | once llcode : forall clike_expand_macros_code(env, node); 71 | } 72 | 73 | ///\commentbox{Expand the simplified type definitions representation}\\ 74 | function clike_patch_type(t, p) 75 | { 76 | n = mkref([]); 77 | t1 = visit:clike(lltypepatch: p) { 78 | deep lltypepatch { 79 | v -> { n:=nm; return t; } 80 | | else -> node 81 | } 82 | }; 83 | return (t1 : 'v'(^n)); 84 | } 85 | 86 | ///\commentbox{Collapse type with attributes into a qualified type} 87 | function clike_collapse_type_attr(as, tp) { 88 | get_aspace(as) = { 89 | lst = map append a in as do { 90 | match a with 91 | addrspace(n) -> [n] 92 | | else -> [] 93 | }; 94 | if (lst) car(lst) else [] 95 | }; 96 | mkqual(as, t) = { 97 | if (as) { 98 | alst = map append a in as do { 99 | match a with 100 | a(id) -> [id] 101 | | else -> [] 102 | }; 103 | if (alst) { 104 | return 'qual'(unifiq(alst), t) 105 | } else t 106 | } else t 107 | }; 108 | visit:clike(lltype:tp) { 109 | once lltype { 110 | attr -> clike_collapse_type_attr(a:as, t) 111 | | array -> { 112 | s = get_aspace(as); 113 | if (s) mkqual(as, mk:node(spc = [s])) else mkqual(as, node) 114 | } 115 | | ptr -> { 116 | s = get_aspace(as); 117 | if (s) mkqual(as, mk:node(spc = [s])) else mkqual(as, node) 118 | } 119 | | else -> mkqual(as, node)}} 120 | } 121 | 122 | ///\commentbox{Some core macros are build into clike ast, but must be expanded into simpler constructions before compilation begins and even before the user-defined macro expansion pass. The reason for this simple core macros is in the simplicity of the parser.}\\ 123 | function clike_expand_core(tl) 124 | { 125 | if((^clike_debug_level)>1) println(#`(SRC: ,tl)); 126 | visit:clike(lltoplev: tl) { 127 | // llvarname is a part of a simplified type definition 128 | once llvarname { 129 | v -> fun(t) {t : node} 130 | | p -> fun(t) clike_patch_type(t,p) 131 | | else -> ccerror('CLIKE:OOPS'(node)) 132 | }; 133 | // Top level global definitions are converted from a simplified form 134 | deep lltoplev { 135 | global -> { = name(tp); mk:node(tp=nt, name=nn) } 136 | | eglobal -> { = name(tp); mk:node(tp=nt, name=nn) } 137 | | else -> node 138 | }; 139 | // Same for structure elements 140 | deep llmacrostrelt : { = fld(t); [cadr(nn);nt] }; 141 | // And functions arguments 142 | deep llfuncarg : { = name(tp); [nt; nn] }; 143 | // There is no underlying string type, so it is expanded here. 144 | // Simplified structure is converted into a normal one 145 | deep lltype { 146 | string -> 'ptr'('integer'('i8')) 147 | | macrostruct -> 'struct'(nm,@ts) 148 | | attr -> clike_collapse_type_attr([a], t) 149 | | else -> node 150 | }; 151 | deep llexpr { 152 | // Simple parsed 'in-expression-block' is converted into a normal one 153 | protoinblock -> 'inblock'(LOC,'begin'(@cuttail(c)),{ 154 | match lasttail(c) with 155 | ['expr'(e)] -> e 156 | | else -> ccerror('CLIKE:INCORRECT-INBLOCK'(node)) 157 | }) 158 | // Comma-delimited list of expressions is translated into an in-block 159 | | commaexprs -> 'inblock'(LOC,'begin'(@map e in cuttail(es) do 160 | 'expr'(e)), 161 | car(lasttail(es))) 162 | | else -> node 163 | }; 164 | deep llcode { 165 | // Compiler backend knows nothing about variable initialisers, 166 | // so here 'manyvardefs' is expanded into simpler constructions. 167 | manyvardefs -> 'begin'( 168 | @map append vars do { 169 | match vars with 170 | s(nm) -> { 171 | = nm(tp); 172 | ['vardef'(nt,nn)] 173 | } 174 | | d(nm,ini) -> { 175 | = nm(tp); 176 | ['vardef'(nt,nn);'set'([], 'var'(cadr(nn)), ini)] 177 | } 178 | } 179 | ) 180 | // For, as it parsed, should be translated into a simpler form to 181 | // be compiled. 182 | | protofor -> 'for'(LOC, init, (match cnds with 183 | [one] -> one 184 | | one : many -> 'logand'([],one,@many) 185 | | [] -> 'const'('integer'('i32',1))), 186 | (match steps with 187 | [one] -> 'expr'(one) 188 | | else -> 189 | 'begin'(@map steps do 'expr'(steps))), 190 | body) 191 | // A single embedded set expression is translated into a statement, 192 | // just for a better readability of an intemediate code. 193 | | expr -> ( 194 | match e with 195 | 'eset '(l,n,v) -> 'set'(l,n,v) 196 | | else -> node 197 | ) 198 | | else -> node 199 | } 200 | } 201 | } 202 | 203 | function clike_expand_core_expr(e) 204 | cadr(clike_expand_core('xxexpr'(e))); 205 | 206 | function clike_expand_core_code(e) 207 | cadr(clike_expand_core('xxcode'(e))); 208 | 209 | ///\commentbox{A shortcut for defining Clike macros in the default macro environment}\\ 210 | #(macro clike_defmacro (name args . body) 211 | `(hashput clike_default_mcenv ,(S<< name) 212 | (fun (env macro-body) 213 | (format macro-body ,args 214 | ,@body)))) 215 | 216 | ///\commentbox{A shortcut for defining Clike typed macros in the default macro environment}\\ 217 | #(macro clike_deftexpander (name args . body) 218 | `(hashput clike_default_mcenv ,(S<< " :typexpander: " name) 219 | (fun (env return_type macro-body macroenv) 220 | (format macro-body ,args 221 | ,@body)))) 222 | 223 | ///\commentbox{A shortcut for defining Clike typing rules in the default macro environment}\\ 224 | #(macro clike_deftrules (name args . body) 225 | `(hashput clike_default_mcenv ,(S<< " :typrules: " name) 226 | (fun (env macro-body macroenv) 227 | (format macro-body ,args 228 | ,@body)))) 229 | 230 | 231 | } -------------------------------------------------------------------------------- /clike/clike-lib.hl: -------------------------------------------------------------------------------- 1 | #(ctimex (define debug-display-include-paths #t)) 2 | #(ctimex (define compiler-optimise-cache nil)) 3 | 4 | #(ctimex (begin 5 | (define assembly-version (S<< "0.1.0.0")) 6 | (define assembly-keyfile "lvmkey.snk") 7 | (define compiler-optimise-cache nil) 8 | )) 9 | 10 | #(n.module CLikeCore) 11 | 12 | ------------------------------------- 13 | 14 | #(usedll MBaseLLVM) 15 | 16 | function clike_ir_post(mdl, code) 17 | return mdl 18 | 19 | define clike_no_llvm = mkref([]); 20 | define clike_outfile_v = mkref([]); 21 | define clike_debug_level = mkref(0); 22 | define clike_default_mcenv = mkhash(); 23 | 24 | include "./clike.hl"; 25 | 26 | include "./clike-utils.hl"; 27 | 28 | include "./clike-llvm.hl"; 29 | 30 | include "./clike-api.hl"; 31 | 32 | 33 | -------------------------------------------------------------------------------- /clike/clike-llvm.hl: -------------------------------------------------------------------------------- 1 | -------------- 2 | 3 | function clike_get_ptr(nm) 4 | { 5 | t = shashget(getfuncenv(), 'clike-current-env'); 6 | return (hashget(t, %S<<(" :refl: (",nm,")")))(); 7 | } 8 | 9 | function register_ptr(env, nm, ptr) 10 | { 11 | env /! %S<<(" :refl: (",nm,")") <- ptr; 12 | return ptr 13 | } 14 | 15 | function clike_llvm_codename(llcode) 16 | match llcode with 17 | %function(cc,name,@_) -> name 18 | | else -> [] 19 | 20 | function clike_compile_ast(mdl, env, code) 21 | { 22 | match code with 23 | [pfront(x)] -> { codex = %hlevel-compile(x); 24 | %read-compile-eval(codex); 25 | } 26 | | else -> { 27 | llcode = clike_to_llvm(env,code); 28 | if(deref(clike_no_llvm)) { 29 | llcode1 = clike_ir_post(mdl, llcode); 30 | //iter l in llcode1 do 31 | // fprintln(deref(clike_outfile_v), %to-string(l)) 32 | } else 33 | iter llcode do { 34 | if(deref(clike_debug_level)>7) println(#`(LLVM: ,llcode)); 35 | nm = clike_llvm_codename(llcode); 36 | pt = llvm_emit(mdl, llcode); 37 | if(nm) register_ptr(env, nm, pt); 38 | } 39 | } 40 | } 41 | 42 | function clike_compile_stream(mdl, env, str) 43 | { 44 | ccode = mkref(nil); 45 | collectcode(c) = {%r!(ccode,c:deref(ccode))}; 46 | flushcode() = { 47 | code = reverse(deref(ccode)); 48 | %r!(ccode,nil); 49 | clike_compile_ast(mdl, env, code); 50 | }; 51 | mcadd(v) = 52 | do mcadd(v=v) { 53 | match v with 54 | [] -> [] 55 | | 'pfront'(code) -> { 56 | flushcode(); 57 | codex = %hlevel-compile(code); 58 | %read-compile-eval(codex); 59 | } 60 | | 'pfrontext'(fn) -> { 61 | flushcode(); 62 | fn(mdl, env, flushcode, mcadd); 63 | } 64 | | else -> collectcode(v) 65 | }; 66 | ploop(%peg:makeenv(), str, peg_pfclike, mcadd); 67 | flushcode(); 68 | } 69 | 70 | function clike_compile_file(mdl, env, fname) 71 | { 72 | oxpath = %corelib:get-lookup-path(); 73 | fp = %generic-filepath(fname); 74 | %corelib:set-lookup-path(%_getpath(fp)); 75 | str = mkref(%peg:file->stream(fp)); 76 | ret = clike_compile_stream(mdl, env, str); 77 | %corelib:set-lookup-path(oxpath); 78 | return ret; 79 | } 80 | 81 | function clike_compile_string(mdl, env, s) 82 | { 83 | str = mkref(%peg:str->stream(s)); 84 | clike_compile_stream(mdl, env, str); 85 | } 86 | 87 | function clike_bypass_one(mdl, env, llcode) 88 | match llcode with 89 | comment(clike(x)) -> clike_compile(fun(t) {clike_bypass_one(mdl, env, t)}, env, x) 90 | | else -> { 91 | nm = clike_llvm_codename(llcode); 92 | pt = llvm_emit(mdl, llcode); 93 | if(nm) register_ptr(env, nm, pt); 94 | } 95 | 96 | function clike_bypass_file(mdl, env, fn) 97 | { 98 | fi0 = %io-open-read(fn); 99 | fi = mkreader(fi0); 100 | do loop () { 101 | r = %xio-read(fi); 102 | if(r) { 103 | clike_bypass_one(mdl, env, r); 104 | loop(); 105 | } 106 | }; 107 | %xio-close(fi); 108 | } 109 | 110 | /////////////// Useful things for extending front-end 111 | 112 | syntax in expr, start (pfclike): '[clquot]:t' + 113 | { 114 | clquot := { ".clike" "`" [cltop]:t "`" => t } 115 | / { ".clike-expr" "`" [clexpr]:t "`" => t } 116 | / { ".clike-code" "`" [clcode]:t "`" => t } 117 | / { ".clike-type" "`" [cltype]:t "`" => t } 118 | ; 119 | } 120 | { 'qquote'(t) } 121 | 122 | 123 | function clike_symbol(v) 124 | match v with 125 | stmt(expr(var(v))) -> v 126 | | else -> [] 127 | 128 | function clike_get_expr(v) 129 | match v with 130 | stmt(expr(e)) -> e 131 | | else -> [] 132 | 133 | function clike_get_stmt(v) 134 | match v with 135 | stmt(s) -> s 136 | | else -> [] 137 | 138 | function clike_get_type(t) 139 | match t with 140 | type(v) -> v 141 | | else -> [] 142 | 143 | function clike_get_top(t) 144 | match t with 145 | top(t) -> t 146 | | else -> [] 147 | 148 | function clike_get_verb(v) 149 | match v with 150 | verb(x) -> x 151 | | else -> [] 152 | 153 | //////////////////////// 154 | 155 | function clike_renvar_code(c, f, t) 156 | { 157 | ren(nm) = if(nm === f) t else nm; 158 | visit:clike(llcode:c) { 159 | deep llexpr { 160 | var -> mk:node(nm=ren(nm)) 161 | | else -> node 162 | }; 163 | deep lvalue { 164 | var -> mk:node(nm=ren(nm)) 165 | | else -> node 166 | }; 167 | } 168 | } 169 | 170 | function clike_renvar_expr(c, f, t) 171 | cadr(clike_renvar_code('expr'(c),f,t)) 172 | 173 | 174 | syntax in top, start (pfclike): '".C" ":" [cltop]:t' 175 | { 176 | 'expr'('lisp'('ctimex'('clike_compile_ast_simple'('quote'(t))))) 177 | } 178 | 179 | syntax in top, start: '".C-init-module" [string]:nm' 180 | { 181 | 'expr'('lisp'(#`(top-begin (define clike-current-env (clike_global_env)) 182 | (define clike-current-llvm-env 183 | (llvm_init_module ,nm))))) 184 | } 185 | 186 | function clike_compile_ast_simple(cast) 187 | clike_compile_ast(shashget(getfuncenv(),'clike-current-env'), 188 | shashget(getfuncenv(),'clike-current-llvm-env'), 189 | [cast]) 190 | -------------------------------------------------------------------------------- /clike/clike-parser-utils.hl: -------------------------------------------------------------------------------- 1 | 2 | function %peg-function-cdr(l) cdr(l) 3 | 4 | #(function __peg-stream-delta (s1 s2) 5 | `(,(StreamEntry.idx s1) ,(StreamEntry.idx s2)) 6 | ) 7 | 8 | #(macro peg-function-source () 9 | `(__peg-stream-delta saved (deref source))) 10 | 11 | #(macro peg-function-position () 12 | `(StreamEntry.idx saved)) 13 | 14 | #(macro peg-function-region () 15 | `(__peg:get-delta saved (__peg:get-position_ source))) 16 | 17 | 18 | #(function peg-function-sm (a b) 19 | (Sm<< a b)) 20 | 21 | 22 | #(function peg-function-smm (a b) 23 | (Sm<< "_" a b)) -------------------------------------------------------------------------------- /clike/clike-standalone.hl: -------------------------------------------------------------------------------- 1 | #(ctimex (define debug-display-include-paths #t)) 2 | #(ctimex (define compiler-optimise-cache nil)) 3 | 4 | #(ctimex (begin 5 | (define assembly-version (S<< "0.1.0.0")) 6 | (define assembly-keyfile "lvmkey.snk") 7 | (define compiler-optimise-cache nil) 8 | )) 9 | 10 | #(n.module CLikeSCore) 11 | 12 | #(sysdll MBaseLogic) 13 | #(sysdll MBaseExtra) 14 | 15 | include "../backend/alt.hl" 16 | 17 | ------------------------------------- 18 | 19 | // STUBS: 20 | 21 | function llvm_emit(mdl, code) [] 22 | 23 | function llvm_init_module(nm) collector(add, get) { 24 | return [add;get;nm;fun() []] 25 | } 26 | 27 | function llvm_save(mdl, name) { 28 | <[add;get;nm;prev]> = mdl; 29 | c = get(); 30 | return ir2backend(c, nm, prev()) 31 | } 32 | 33 | define llvm_no_engine = mkref([]) 34 | define %llvm-optimise = mkref([]) 35 | 36 | function clike_ir_post(mdl, llcode) { 37 | <[add;get;nm;prev]> = mdl; 38 | iter c in llcode do add(c) 39 | } 40 | 41 | ------------------------------------- 42 | 43 | define clike_no_llvm = mkref(true); 44 | define clike_outfile_v = mkref([]); 45 | define clike_debug_level = mkref(0); 46 | define clike_default_mcenv = mkhash(); 47 | define clike_alt_backend = mkref([]); 48 | define clike_alt_backend_hook = mkref([]); 49 | 50 | 51 | include "./clike.hl"; 52 | include "./clike-utils.hl"; 53 | include "./clike-llvm.hl"; 54 | include "./clike-api.hl"; 55 | 56 | 57 | -------------------------------------------------------------------------------- /clike/clike-types-utils.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \section{Utility functions for the typing pass} 4 | 5 | \pfcode{ 6 | 7 | // Strip from qualifiers 8 | function clike_unqualify(tp) 9 | visit:clike(lltype:tp) {deep lltype { 10 | qual -> t 11 | | else -> node 12 | }} 13 | 14 | // Check if a type is a structure 15 | function clike_isstruct(x) 16 | match x with 17 | 'struct'([nm],@_) -> nm 18 | | 'structalias'(nm) -> nm 19 | | 'structref'(nm) -> nm 20 | | else -> [] 21 | 22 | // Convert a type into a canonical form 23 | function clike_type_canonical(t) 24 | visit:clike(lltype: clike_unqualify(t)) {deep lltype { 25 | struct -> {if(nm) 'structalias'(car(nm)) else node} 26 | | array -> 'ptr'(t) 27 | | else -> node 28 | }} 29 | 30 | // Get s string representation of a type 31 | function clike_type_string(t) 32 | %to-string(clike_type_canonical(t)) 33 | 34 | function clike_type_isa_pointer(t) 35 | match t with 36 | 'array'(@_) -> true 37 | | 'ptr'(@_) -> true 38 | | else -> [] 39 | 40 | // Check if two types are identical 41 | // TODO: check array dimensions 42 | function clike_type_iso(a, b) 43 | do loop(t1=a, t2=b) { 44 | match t1:t2 with 45 | 'integer'(t1):'integer'(t2) -> %eqv?(t1,t2) 46 | | 'ptr'(a):'ptr'(b) -> loop(a,b) 47 | | 'ptr'(a):'array'(b,@r1) -> loop(a,b) 48 | | 'array'(a,@r):'ptr'(b) -> loop(a,b) 49 | | 'array'(a,@r):'array'(b,@r1) -> and(loop(a,b),iso(r,r1)) 50 | | x:y -> { 51 | s1 = clike_isstruct(x);s2=clike_isstruct(y); 52 | if(and(s1,s2)) %eqv?(s1,s2) else iso(x,y) 53 | }} 54 | 55 | 56 | parser clike_inttype_parser (pfront) { 57 | clike_inttype_parser := { "sb" [number]:n => sb(n) } 58 | / { "ub" [number]:n => ub(n) } 59 | / { "i" [number]:n => i(n) } 60 | / { "u" [number]:n => u(n) } 61 | ; 62 | } 63 | 64 | function clike_parse_inttype(itype) 65 | { tmp = parse %S<<(itype) as clike_inttype_parser; 66 | match tmp with 67 | 'sb'(n) -> tmp 68 | | 'ub'(n) -> tmp 69 | | 'i'(n) -> tmp 70 | | 'u'(n) -> tmp 71 | | else -> []} 72 | 73 | // Check if an integer is of a signed kind 74 | function clike_signed_int(itype) 75 | case itype { 76 | 'i8'|'i16'|'i32'|'i64' -> true 77 | | 'u8'|'u16'|'u32'|'u64' -> nil 78 | | else -> 79 | (match clike_parse_inttype(itype) with 80 | 'sb'(n) -> true 81 | | 'ub'(n) -> [] 82 | | else -> ccerror('CLIKE:INCORRECT-INTEGER-SPEC'(itype))) 83 | } 84 | 85 | // Check if a type is signed, if this notion applies 86 | function clike_signed(tp) 87 | visit:clike(lltype: tp) {once lltype { 88 | integer -> clike_signed_int(itype) 89 | | real -> true 90 | | ptr -> nil 91 | | array -> nil 92 | | string -> nil 93 | | else -> ccerror('CLIKE:INCORRECT-TYPE'(tp)) 94 | }} 95 | 96 | // A representation for C strings 97 | define clike_string_type = 'ptr'('integer'('i8')); 98 | 99 | // A helper function which detects a type of a given constant literal 100 | function clike_const_type(c) 101 | visit:clike(llconst:c) { 102 | deep llconst { 103 | null -> 'null'() 104 | | integer -> 'integer'(itype) 105 | | real -> 'real'(rtype) 106 | | string -> clike_string_type 107 | | constarray -> 'array'(caar(elts)) // this is why it is deep 108 | | conststruct -> t 109 | }} 110 | 111 | // A helper function which returns an array element type 112 | function clike_array_elt_type(tp) 113 | match tp with 114 | ptr(array(t,@x)) -> t 115 | | ptr(ptr(t)) -> t 116 | | arg(array(t,@x)) -> t 117 | | arg(ptr(t)) -> t 118 | | else -> ccerror('CLIKE:ARRAY-TYPE'(tp)) 119 | 120 | // A helper function which makes a reference type for a given type 121 | function clike_make_ref_type(tp) 122 | return 'ptr'(tp) 123 | 124 | // A helper function which returns a type referenced by a given reference type 125 | function clike_deref_type(tp) 126 | match tp with 127 | ptr(e) -> e 128 | | else -> ccerror('CLIKE:DEREF-TYPE'(tp)) 129 | 130 | function clike_getstruct(tp) 131 | match tp with 132 | ptr(e) -> e 133 | | else -> tp 134 | 135 | // A helper function which gives a type of a named structure field 136 | function clike_fieldtype(tp, fldnm) 137 | match clike_getstruct(tp) with 138 | struct(nm,@elts) -> { 139 | v = filter(fun(x) %eqv?(car(x),fldnm), elts); 140 | if(v) cadr(car(v)) else 141 | ccerror('CLIKE:STRUCT-NO-SUCH-FIELD'(tp, fldnm))} 142 | | else -> ccerror('CLIKE:STRUCT-TYPE'(tp)) 143 | 144 | // Returns a number of a field 145 | function clike_fieldnumber(tp, fldnm) 146 | match clike_getstruct(tp) with 147 | struct(nm,@elts) -> 148 | do loop(es = elts, i = 0) 149 | { 150 | match es with 151 | [nm;tp]:rest -> { 152 | if(%eqv?(nm, fldnm)) i 153 | else loop(rest,i+1) 154 | } 155 | | else -> ccerror('CLIKE:STRUCT-NO-SUCH-FIELD'(tp, fldnm)) 156 | } 157 | | else -> ccerror('CLIKE:STRUCT-TYPE'(tp)) 158 | 159 | // Make a typed node with a binary expression, give it a type of a first 160 | // argument. 161 | function clike_binopsimple(LOC,op,l,r) 162 | return car(l):'bin'(LOC,op,l,r) 163 | 164 | function clike_modopsimple(LOC,op,l,r) 165 | return clike_deref_type(car(l)):'modop'(LOC,op,l,r) 166 | 167 | // Cast one type to another. 168 | // In LLVM, array of a fixed size and a pointer are different 169 | function clike_castto(t,n) 170 | match t:car(n) with 171 | ptr(t1):null() -> t:'const'('null'()) 172 | | ptr(t1):array(t2,@_) -> 173 | if(clike_type_iso(t1,t2)) 174 | t:'ref'(t:'array'('ptr'(car(n)):cdr(n), 175 | ['nop']:'const'('integer'('i32',0)))) 176 | else return t:'typecast'(t,n) 177 | | else -> return t:'typecast'(t,n) 178 | 179 | // Adjust an integer to the size of a pointer type 180 | function clike_ptrarith(LOC,op, ptr, i) 181 | { 182 | = i; 183 | = ptr; 184 | if(not(%eqv?(op,'add'))) ccerror(#`(POINTER OP NOT SUPPORTED)); 185 | 'ref'(ptp:'array'('ptr'(ptp):p,i)) 186 | } 187 | 188 | // Adjust an integer to the size of a pointer type 189 | function clike_ptrarithMOD(LOC,op, ptr, i) 190 | { 191 | = i; 192 | = ptr; 193 | pitp = clike_deref_type(ptp); 194 | if(not(%eqv?(op,'add'))) ccerror(#`(POINTER OP NOT SUPPORTED)); 195 | 'eset'([], ptr, pitp:'ref'(clike_deref_type(pitp):'array'(ptr,i))) 196 | } 197 | 198 | function clike_rank(i) 199 | case i { 200 | 'i8' -> 1 | 'u8' -> 2 | 'i16' -> 3 | 'u16' -> 4 201 | | 'i32' -> 5 | 'u32' -> 6 | 'i64' -> 7 | 'u64' -> 8 202 | | else -> { 203 | aif(rnk = clike_parse_inttype(i)) { 204 | cadr(rnk) + 100 205 | } else 0 206 | } 207 | } 208 | 209 | // Calculate the binary operation type, inject implicit casts if needed 210 | function clike_fix_binoptypes(LOC, op, l,r) 211 | { 212 | tl = clike_unqualify(car(l));tr = clike_unqualify(car(r)); 213 | match tl:tr with 214 | integer(i1):integer(i2) -> 215 | if(%eqv?(i1,i2)) clike_binopsimple(LOC,op,l,r) 216 | else { 217 | if(%>=(clike_rank(i1),clike_rank(i2))) 218 | tl : 'bin'(LOC,op,l,clike_castto(tl,r)) 219 | else 220 | tr : 'bin'(LOC,op,clike_castto(tr,l),r) 221 | } 222 | | integer(i1):real(r2) -> tr:'bin'(LOC,op,clike_castto(tr,l),r) 223 | | real(r1):integer(i2) -> tl:'bin'(LOC,op,l,clike_castto(tl,r)) 224 | | real('float'):real('double') -> tr:'bin'(LOC,op,clike_castto(tr,l),r) 225 | | real('double'):real('float') -> tl:'bin'(LOC,op,l,clike_castto(tl,r)) 226 | | ptr(t1):integer(i2) -> tl:clike_ptrarith(LOC,op,l,r) 227 | | integer(t1):ptr(t2) -> tr:clike_ptrarith(LOC,op,r,l) 228 | | else -> clike_binopsimple(LOC,op,l,r) 229 | } 230 | 231 | // Calculate the binary mod operation type, inject implicit casts if needed 232 | function clike_fix_modoptypes(LOC, op, l,r) 233 | { 234 | tl = clike_deref_type(clike_unqualify(car(l)));tr = clike_unqualify(car(r)); 235 | match tl:tr with 236 | integer(i1):integer(i2) -> if(%eqv?(i1,i2)) clike_modopsimple(LOC,op,l,r) 237 | else tl : 'modop'(LOC, op, l, clike_castto(tl,r)) 238 | | integer(i1):real(r2) -> tl:'modop'(LOC,op,l,clike_castto(tl,r)) 239 | | real(r1):integer(i2) -> tl:'modop'(LOC,op,l,clike_castto(tl,r)) 240 | | real('float'):real('double') -> tl:'bin'(LOC,op,l,clike_castto(tl,r)) 241 | | real('double'):real('float') -> tl:'bin'(LOC,op,l,clike_castto(tl,r)) 242 | | ptr(t1):integer(i2) -> tl:clike_ptrarithMOD(LOC,op,l,r) 243 | | integer(t1):ptr(t2) -> tr:clike_ptrarithMOD(LOC,op,r,l) 244 | /////{\bf TODO: report error}\\ 245 | | else -> clike_modopsimple(LOC,op,l,r) 246 | } 247 | 248 | 249 | // Construct a comparision operation node 250 | function clike_compopsimple(LOC,op,l,r) 251 | return 'compop'(LOC,op,l,r) 252 | 253 | // Fix the comparision operation arguments, if needed 254 | function clike_fix_compoptypes(LOC,op,l,r) 255 | { 256 | tl = clike_unqualify(car(l));tr = clike_unqualify(car(r)); 257 | match tl:tr with 258 | integer(i1):integer(i2) -> 259 | if(%eqv?(i1,i2)) clike_compopsimple(LOC,op,l,r) 260 | else { 261 | cparses(s) = %S->N(%S<<(cdr(%symbol->list(s)))); 262 | n1 = cparses(i1);n2=cparses(i2); 263 | if(n1>n2) 'compop'(LOC,op,l,clike_castto(tl,r)) 264 | else 'compop'(LOC,op,clike_castto(tr,l),r) 265 | } 266 | | integer(i1):real(r2) -> 'compop'(LOC,op,clike_castto(tr,l),r) 267 | | real(r1):integer(i2) -> 'compop'(LOC,op,l,clike_castto(tl,r)) 268 | | real('float'):real('double') -> 'compop'(LOC,op,clike_castto(tr,l),r) 269 | | real('double'):real('float') -> 'compop'(LOC,op,l,clike_castto(tl,r)) 270 | | ptr(t1):integer(i2) -> 'compop'(LOC,op,l,r) 271 | | ptr(t1):null() -> 'compop'(LOC,op,l,'ptr'(t1):'const'('null'())) 272 | | null():ptr(t1) -> 'compop'(LOC,op,'ptr'(t1):'const'('null'()),r) 273 | | integer(t1):ptr(t2) -> 'compop'(LOC,op,l,r) 274 | | else -> clike_compopsimple(LOC,op,l,r) 275 | } 276 | 277 | // Inject a cast into a right side of a set operation, if needed 278 | function clike_fix_settype(set,loc,l,r) 279 | { 280 | lt = clike_deref_type(clike_unqualify(car(l))); 281 | rt = car(r); 282 | if(clike_type_iso(lt,rt)) [set;loc;l;r] 283 | else 284 | match lt:rt with 285 | ptr(t1):null() -> [set;loc;l;'ptr'(t1):'const'('null'())] 286 | | else -> [set;loc;l;clike_castto(lt,r)] 287 | } 288 | 289 | function clike_fix_return(e,lt) 290 | { 291 | rt = car(e); 292 | if(clike_type_iso(lt,rt)) e 293 | else 294 | match lt:rt with 295 | ptr(t1):null() -> 'ptr'(t1):'const'('null'()) 296 | | else -> clike_castto(lt,e) } 297 | 298 | 299 | // Inject casts into function arguments, if needed 300 | function clike_fix_funcall(call,LOC,fn, va, args, atps) 301 | { 302 | %__lcut(l1,l2) = do loop(a=l1,b=l2) if(a) loop(cdr(a),cdr(b)) else b; 303 | [call;LOC;fn;@map az in zip(args,atps) do { 304 | <[a; tt]> = az; at=clike_unqualify(car(a)); 305 | if(clike_type_iso(at,tt)) 306 | return a 307 | else return clike_castto(tt,a); 308 | }; 309 | @if(va) %__lcut(atps,args) else [] 310 | ] 311 | } 312 | 313 | // A shortcut for building a zero comparision operation 314 | function clike_notzero(e0) 315 | { 316 | = e0; 317 | 'compop'([],'ne',e0,tp:'const'('zero'(tp))) 318 | } 319 | 320 | // Fix boolean expressions - compare to zero if a value is not a 321 | // boolean already 322 | function clike_fix_bool(e) 323 | match clike_unqualify(car(e)) with 324 | bool() -> e 325 | | else -> 'bool'() : clike_notzero(e) 326 | 327 | 328 | function clike_decay(tp) 329 | visit:clike(lltype: tp) { 330 | once lltype { 331 | array -> 'ptr'(t) 332 | | else -> node 333 | } 334 | } 335 | } -------------------------------------------------------------------------------- /clike/clike-types.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \subsection{A compilation pass: types propagation} 4 | 5 | N.B. ---- a typed macros expansion step is performed within this pass as well. 6 | 7 | \pfcode{ 8 | function clike_types_inner (env, c, toploop, rettype) 9 | { 10 | vars = mkhash(); 11 | do loop(c0 = c) { 12 | visit:clike(llcode: c0) 13 | { 14 | deep lltype { 15 | typedmacro -> { 16 | macroenv = mkref([]); 17 | rule = clike_env_gettypingrules(env, nm); 18 | rtype = if(rule) rule(env, args, macroenv) else []; 19 | expander = clike_env_gettypedexpander(env, nm); 20 | ncode_0 = expander(env, rtype, args, macroenv); 21 | // args are going to be stripped from types 22 | // during this expansion 23 | ncode = loop('passtype'(ncode_0)); // redo the propagation 24 | return ncode 25 | } 26 | | else -> node}; // do not type constexprs there 27 | deep llvarname { 28 | v -> name 29 | | p -> ccerror('CLIKE:WRONG-PASS'(node)) 30 | }; 31 | deep llexpr { 32 | call -> { 33 | nid = clike_env_name_resolve(env, id); 34 | = clike_env_funcretargtypes(env, nid); 35 | return tp : clike_fix_funcall('call', LOC, nid, va, args, atps); 36 | } 37 | | intrinsic -> { 38 | return 'void'() : node 39 | } 40 | | callptr -> { 41 | = clike_funcptrtype(car(fn)); 42 | return tp : clike_fix_funcall('callptr', LOC, fn, va, args, atps); 43 | } 44 | | stdcallpfx -> car(e):node 45 | | bin -> clike_fix_binoptypes(LOC, op,l,r) 46 | | compop -> 'bool'() : clike_fix_compoptypes(LOC, op ,l,r) 47 | | un -> case op { 'minus' -> car(e) : node 48 | | 'not' -> 'bool'():mk:node(e = clike_fix_bool(e)) } 49 | | tri -> car(tr) : (mk:node(cnd=clike_fix_bool(cnd))) 50 | | typecast -> { 51 | t1 = clike_env_unitype(env, t); 52 | clike_castto(t1, e) 53 | } 54 | | bitcast -> { 55 | t1 = clike_env_unitype(env, t); 56 | t1 : mk:node(t = t1) 57 | } 58 | | pre -> car(v) : mk:node(vtyp = [car(v)]) 59 | | post -> car(v) : mk:node(vtyp = [car(v)]) 60 | | inblock -> car(r) : node 61 | | eset -> clike_deref_type(car(v)) : clike_fix_settype('eset',LOC,v,e) 62 | // TODO: implicit casts for modops 63 | | modop -> clike_fix_modoptypes(LOC, op, l, r) 64 | | globstring -> clike_string_type:node 65 | | const -> {clike_const_type(c) : 66 | match c with 67 | ['string';s] -> 'globstring'(s) 68 | | else -> node } 69 | | var -> { 70 | v1 = vars /@ nm; 71 | if(v1) v1:node else 72 | { 73 | v2 = clike_env_argtype(env, nm); 74 | if(v2) v2:'arg'(nm) else 75 | { 76 | nnm = clike_env_name_resolve(env, nm); 77 | v3 = clike_env_globtype(env, nnm); 78 | if(v3) v3:'glob'(nnm) else 79 | { v4 = clike_env_globfunctype(env, nnm); 80 | if(v4) v4:'globfun'(nnm) else 81 | ccerror('CLIKE:UNKNOWN-VAR'(nm)) 82 | }}}} 83 | | arg -> { v2 = clike_env_argtype(env, nm); v2 : node } 84 | | glob -> { v3 = clike_env_globtype(env, nm); v3 : node } 85 | | globfun -> { v4 = clike_env_globfunctype(env, nm); v4:node } 86 | | array -> clike_array_elt_type(car(ar)) : node 87 | | ref -> car(e) : node // It's an lvalue already, must be a ref anyway 88 | | deref -> clike_deref_type(car(e)) : node 89 | | getelt -> clike_fieldtype(car(e), fldnm) : node 90 | | sizeof -> 'integer'('i64') : node 91 | | logand -> 'bool'():'logand'(LOC,@map es do clike_fix_bool(es)) 92 | | logor -> 'bool'():'logor'(LOC,@map es do clike_fix_bool(es)) 93 | 94 | // Applying type rules for a dual-stage macro: 95 | | typedmacro -> { 96 | macroenv = mkref([]); 97 | rule = clike_env_gettypingrules(env, nm); 98 | rtype = if(rule) rule(env, args, macroenv) else []; 99 | expander = clike_env_gettypedexpander(env, nm); 100 | ncode_0 = expander(env, rtype, args, macroenv); 101 | // args are going to be stripped from types 102 | // during this expansion 103 | ncode = loop('passexpr'(ncode_0)); // redo the propagation 104 | return ncode 105 | } 106 | | inline -> return ret:node 107 | | else -> ccerror('CLIKE:NOT-ALLOWED-HERE'(node)) 108 | }; 109 | deep llcode { 110 | vardef -> { 111 | ntp = clike_env_unitype(env, tp); 112 | vars /! name <- clike_decay(ntp); 113 | cdr(env) /! name <- 'lvar'(ntp); 114 | return mk:node(tp = ntp); 115 | } 116 | | varinit -> { 117 | rtp = car(r); 118 | vars /! l <- clike_decay(rtp); 119 | cdr(env) /! l <- 'lvar'(rtp); 120 | return 'begin'('vardef'(rtp,l), 121 | 'set'([],'ptr'(rtp):'var'(l) , r)) 122 | } 123 | | toplift -> {toploop(env, t); 'begin'()} 124 | | set -> clike_fix_settype('set',LOC,l,e) 125 | | passexpr -> return e 126 | | passtype -> return e 127 | | if2 -> mk:node(e=clike_fix_bool(e)) 128 | | if3 -> mk:node(e=clike_fix_bool(e)) 129 | | for -> mk:node(cnd=clike_fix_bool(cnd)) 130 | | do -> mk:node(cnd=clike_fix_bool(cnd)) 131 | | while -> mk:node(cnd=clike_fix_bool(cnd)) 132 | | return -> mk:node(e=clike_fix_return(e, rettype)) 133 | | else -> return node 134 | }; 135 | deep lvalue { 136 | var -> { 137 | = loop('passexpr'(node)); 138 | match vv with 139 | arg(_) -> 'arg'(vt):vv 140 | | else -> clike_make_ref_type(vt):vv 141 | } 142 | | array -> clike_make_ref_type(clike_array_elt_type(car(ar))):node 143 | | deref -> { 144 | match e with 145 | ptr(t):arg(a) -> e 146 | | array(t,@idxs):arg(a) -> e 147 | | t:x -> t:node 148 | } 149 | | getelt -> clike_make_ref_type(clike_fieldtype(car(e),fldnm)):node 150 | | else -> ccerror('CLIKE:WRONG-PASS'(node)) 151 | }; 152 | }} 153 | } 154 | } 155 | 156 | 157 | 158 | An additional tiny pass which replaces the abstract 'bool' with 159 | a concrete ingeger type. Bool was needed for fixing boolean expressions, 160 | and it should not interfere later with casting compilation. 161 | 162 | \pfcode{ 163 | function clike_clean_bools(code) { 164 | visit:clike2(llcode: code) { 165 | deep lltype { 166 | bool -> 'integer'('i32') 167 | | else -> node 168 | } 169 | } 170 | }} 171 | 172 | 173 | \pfcode{ 174 | ///\commentbox{An interface function, binds all the typing passes together}\\ 175 | function clike_types (env, c, toploop, rettype) 176 | clike_clean_bools(clike_types_inner(env,c,toploop, rettype)) 177 | } 178 | 179 | \pfcode{ 180 | ///\commentbox{Convert clike2 back into clike}\\ 181 | function clike_untype_llcode(c) { 182 | visit:clike2(llcode:c) 183 | { deep llcode { 184 | passexpr -> e 185 | | passlvalue -> e 186 | | passtype -> e 187 | | else -> node 188 | }; 189 | deep llexpr : e; deep lvalue : e;} 190 | }} 191 | 192 | 193 | \pfcode{ 194 | ///\commentbox{Convert clike2 back into clike}\\ 195 | function clike_untype_llexpr(c) 196 | clike_untype_llcode('passexpr'(c)) 197 | } 198 | 199 | \pfcode{ 200 | ///\commentbox{Convert clike2 back into clike}\\ 201 | function clike_untype_lvalue(c) 202 | clike_untype_llcode('passlvalue'(c)) 203 | } 204 | -------------------------------------------------------------------------------- /clike/clike-utils.hl: -------------------------------------------------------------------------------- 1 | // N.B. : 'pfront'(...) is not even a part of the AST. But who cares? 2 | syntax of pfclike in cltop, start: ' "##" [atopexpr]:e ' 3 | { 'pfront'(e) } 4 | 5 | 6 | syntax of pfclike in cltop, start: ' clike macro [clqident]:nm? "{" 7 | syntax ":" [mpeg]:r ";"? 8 | typing ":" [expr]:rs ";"? 9 | expand as ":" [expr]:e ";"? 10 | "}" ' 11 | { 12 | code = #`(clike_maketexpander ,nm ,r ,rs ,e); 13 | res = 'expr'('lisp'(code)); 14 | return 'pfront'(res) 15 | } 16 | 17 | function %_clike_make_syntax(mnm, r, ps) 18 | { 19 | body = 20 | #`(let ,(foreach-map (p ps) 21 | (format p (n t) 22 | `(,n ,(case t 23 | ((clexpr clexpr0 ) `(list 'expr ,n)) 24 | ((cllvalue) `(list 'lvalue ,n)) 25 | ((cltype) `(list 'type ,n)) 26 | ((clqident) `(list 'var ,n)) 27 | ((clcode) `(list 'stmt ,n)) 28 | ((expr) `(list 'verb ,n)) 29 | )))) 30 | (list 'typedmacro (quote ,mnm) 31 | ,@(map car ps))); 32 | = r; 33 | #`(peg-minigrammar pfclike clexpr_inner 34 | () 35 | (,cde (() (action ,body))) 36 | ,@hlevel-default-entries 37 | ,@rst 38 | ) 39 | } 40 | 41 | function clike_makenop(v) 'NOP' 42 | 43 | function %_clike_select_gettype(t) 44 | case t { 45 | 'clexpr' | 'clexpr0' | 'cllvalue' -> 'car' 46 | | 'cltype' -> 'I' 47 | | 'clqident' | 'expr' | 'clcode' -> 'clike_makenop' 48 | } 49 | 50 | 51 | function %_clike_select_untyper(t) 52 | case t { 53 | 'clexpr' | 'clexpr0' -> 'clike_untype_llexpr' 54 | | 'cllvalue' -> 'clike_untype_lvalue' 55 | | 'cltype' -> 'I' 56 | | 'clcode' -> 'clike_untype_llcode' 57 | | 'clqident' | 'expr' -> 'I' 58 | } 59 | 60 | function %_clike_make_rules(nm, ps, rs) 61 | { 62 | pfcode = pfront_expr(rs); 63 | #`(clike_deftrules ,nm ,(map car ps) 64 | (let ,(map-over ps 65 | (fmt (n t) 66 | `(,n (,(_clike_select_gettype t) (cadr ,n))))) 67 | ,pfcode)) 68 | } 69 | 70 | function %_clike_make_expander(nm, ps, e) 71 | { 72 | pfcode = pfront_expr(e); 73 | #`(clike_deftexpander ,nm ,(map car ps) 74 | (let ,(foreach-mappend (p ps) 75 | (format p (n t) 76 | `((,(Sm<< "typeof_" n) 77 | (,(_clike_select_gettype t) (cadr ,n))) 78 | (,n (,(_clike_select_untyper t) (cadr ,n)))))) 79 | ,pfcode)) 80 | } 81 | 82 | function %_clike_check_ps(ps) 83 | iter ps do { 84 | <[n;t]> = ps; 85 | case t { 86 | 'clexpr' | 'clexpr0' | 'cllvalue' | 'clqident' | 'cltype' | 'expr' 87 | | 'clcode' -> [] 88 | | else -> ccerror('CLIKE:UNSUPPORTED-MACRO-ARG-TYPE'(ps)) 89 | } 90 | } 91 | 92 | macro clike_maketexpander (nm0,r,rs,e) 93 | { 94 | nm = if(nm0) car(nm0) else gensym(); 95 | = r; 96 | ps = %peg-extract-bindings(re); 97 | %_clike_check_ps(ps); 98 | #`(top-begin 99 | ,(_clike_make_syntax nm r ps) 100 | ,(_clike_make_rules nm ps rs) 101 | ,(_clike_make_expander nm ps e) 102 | ) 103 | } 104 | 105 | function clike_convbindtype(env, tp, failp) 106 | { 107 | tp1 = clike_env_unitype(env, tp); 108 | match tp1 with 109 | integer('i32') -> 't_Int32' 110 | | integer('u32') -> 't_UInt32' 111 | | ptr(_) -> 't_object' 112 | | array(@_) -> 't_object' 113 | | else -> failp := true 114 | } 115 | 116 | function clike_makebinding(env, fndef) 117 | { 118 | failp = mkref([]); 119 | ffname = mkref(""); 120 | types = visit:clike(lltoplev: fndef) { 121 | deep lltoplev { 122 | cfunc -> {ffname := name; return args} 123 | | else -> {failp := true; []} 124 | }; 125 | deep llfuncarg: clike_convbindtype(env, tp, failp); 126 | }; 127 | if(^failp) return #`(begin) 128 | else { 129 | fargs = map a in types count i do %Sm<<("a",i); 130 | invcode = #`(llvm_make_invoker ,@types); 131 | bindcode = #`(alet ptr (clike_get_ptr ,(S<< (deref ffname))) 132 | (fun ,fargs (,invcode ptr ,@fargs))); 133 | return bindcode 134 | } 135 | } 136 | 137 | syntax of pfclike in cltop, start: ' "#" include [string]:fname ' 138 | { 139 | 'pfrontext'(fun(mdl, env, flushcode, mcadd) { 140 | flushcode(); 141 | oxpath = %corelib:get-lookup-path(); 142 | fp = %generic-filepath(fname); 143 | %corelib:set-lookup-path(%_getpath(fp)); 144 | str = mkref(%peg:file->stream(fp)); 145 | ploop(%peg:makeenv(), str, peg_pfclike, mcadd); 146 | %corelib:set-lookup-path(oxpath); 147 | flushcode(); 148 | }) 149 | } 150 | -------------------------------------------------------------------------------- /clike/clike.hl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | A C-like language for LLVM. 4 | 5 | A compilation pipeline is following: 6 | 7 | * Top level loop 8 | clike_to_llvm, clike_compile, 9 | * Parser -> clike extended AST 10 | pfront_pfclike grammar 11 | * Macro expansion -> clike simple AST 12 | clike_expand_macros_top 13 | 14 | == Function body level pipeline (clike_compile_code) 15 | 16 | * clike (type propagation, implicit casts and intrinsics injection) -> clike2 17 | clike_types 18 | * clike2 (expanding into LLVM instructions tree) -> clike3 19 | clike_precompile 20 | * clike3 (flattening, metadata cleanup) -> clike3 21 | clike_lift_1, clike_fix_sets, clike_cleanup 22 | * clike3 (basic blocks detection) -> LLVM AST 23 | clike_basicblocks 24 | 25 | */ 26 | 27 | ////// Definitions for ASTs: clike, clike2, clike3 28 | litinclude ("../doc/clike-ast") "./clike-ast.hl"; 29 | ////// Compiler environment support 30 | include "./clike-env.hl"; 31 | ////// Compiler pipeline (after macro expansion) 32 | ////// Types propagation, implicit casts, injections: 33 | litinclude ("../doc/clike-types-utils") "./clike-types-utils.hl"; 34 | litinclude ("../doc/clike-types") "./clike-types.hl"; 35 | ////// Tree compilation, flattening, cleanups: 36 | litinclude ("../doc/clike-compiler") "./clike-compiler.hl"; 37 | ////// Macro expansion engine 38 | litinclude ("../doc/clike-expand") "./clike-expand.hl"; 39 | ////// Top level compiler 40 | litinclude ("../doc/clike-compiler-top") "./clike-compiler-top.hl"; 41 | ////// Parser, syntax extensions 42 | litinclude ("../doc/clike-parser") "./clike-parser.hl"; 43 | 44 | -------------------------------------------------------------------------------- /doc/doc.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/combinatorylogic/clike/c0b3864962f5f8c2b2c5418ae3822748e3942fe6/doc/doc.pdf -------------------------------------------------------------------------------- /doc/doc.tex: -------------------------------------------------------------------------------- 1 | \documentclass[10pt,a4paper]{article} 2 | \usepackage[top=30pt,bottom=40pt,left=48pt,right=46pt]{geometry} 3 | \usepackage{alltt} 4 | \usepackage{ifthen} 5 | \usepackage{calc} 6 | \usepackage{rotating} 7 | \usepackage[usenames]{color} 8 | \usepackage{multicol} 9 | \usepackage[framemethod=tikz]{mdframed} 10 | \usepackage{hyperref} 11 | \usepackage{graphicx} 12 | 13 | \usetikzlibrary{backgrounds,fit,decorations.pathreplacing} 14 | 15 | \definecolor{purple}{rgb}{0.5,0,0.5} 16 | \global\mdfdefinestyle{codeblock}{% 17 | outerlinewidth=2pt,innerlinewidth=0pt, 18 | outerlinecolor=gray,roundcorner=3pt 19 | } 20 | 21 | \global\mdfdefinestyle{demoblock}{% 22 | outerlinewidth=0.5pt,innerlinewidth=0pt, 23 | outerlinecolor=blue,roundcorner=0pt 24 | } 25 | 26 | 27 | 28 | \newcommand{\colobox}[1]{ 29 | \begin{tikzpicture} 30 | [execute at end picture=% 31 | { 32 | \begin{pgfonlayer}{background} 33 | \path[fill=black!10,thick,draw=black!40,rounded corners=0.8mm] 34 | (current bounding box.south west) rectangle 35 | (current bounding box.north east); 36 | \end{pgfonlayer} 37 | }] 38 | \node (box) { 39 | \begin{minipage}{\textwidth} 40 | #1 41 | \end{minipage} 42 | }; 43 | \end{tikzpicture}\\} 44 | 45 | \newcommand{\commentbox}[1]{\colobox{\sl #1}} 46 | 47 | \newcommand{\lspspc}{{\color{white}{\tt{\_}}}} 48 | \newcommand{\lsplp}{(} 49 | \newcommand{\lsprp}{)} 50 | 51 | \newcommand{\docstring}[1]{\sl #1} 52 | \newcommand{\docentry}[1]{\sl #1} 53 | 54 | \newenvironment{pfcodeblock}[1]{}{} 55 | \newcommand{\pfcodeblockbegin}{\begingroup\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=codeblock]} 56 | \newcommand{\pfcodeblockend}{\end{mdframed}\vskip1mm\endgroup} 57 | 58 | \newenvironment{pficodeblock}[1]{}{} 59 | \newcommand{\pficodeblockbegin}{\begingroup} 60 | \newcommand{\pficodeblockend}{\endgroup} 61 | 62 | \newcommand{\pfdemoblockbegin}{\begin{minipage}[t]{0.8\linewidth}\begingroup\fontsize{8}{8}\selectfont\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=demoblock]} 63 | \newcommand{\pfdemoblockend}{\end{mdframed}\vskip1mm\endgroup\end{minipage}} 64 | 65 | 66 | \definecolor{light-gray}{gray}{0.5} 67 | 68 | 69 | \begin{document} 70 | 71 | \tableofcontents 72 | 73 | \newpage 74 | 75 | \input clike-ast 76 | \input clike-parser 77 | \input clike-expand 78 | \input clike-types-utils 79 | \input clike-types 80 | \input clike-compiler 81 | \input clike-compiler-top 82 | 83 | \end{document} 84 | -------------------------------------------------------------------------------- /doc/doc_backend.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{alltt} 3 | \usepackage{rotating} 4 | \usepackage[usenames]{color} 5 | \usepackage[framemethod=tikz]{mdframed} 6 | 7 | \global\mdfdefinestyle{codeblock}{% 8 | outerlinewidth=2pt,innerlinewidth=0pt, 9 | outerlinecolor=gray,roundcorner=3pt 10 | } 11 | 12 | 13 | 14 | \newcommand{\colobox}[1]{ 15 | \begin{tikzpicture} 16 | [execute at end picture=% 17 | { 18 | \begin{pgfonlayer}{background} 19 | \path[fill=black!10,thick,draw=black!40,rounded corners=0.8mm] 20 | (current bounding box.south west) rectangle 21 | (current bounding box.north east); 22 | \end{pgfonlayer} 23 | }] 24 | \node (box) { 25 | \begin{minipage}{\textwidth} 26 | #1 27 | \end{minipage} 28 | }; 29 | \end{tikzpicture}\\} 30 | 31 | \newcommand{\commentbox}[1]{\colobox{\sl #1}} 32 | 33 | \newcommand{\lspspc}{{\color{white}{\tt{\_}}}} 34 | \newcommand{\lsplp}{(} 35 | \newcommand{\lsprp}{)} 36 | 37 | \newcommand{\docstring}[1]{\sl #1} 38 | \newcommand{\docentry}[1]{\sl #1} 39 | 40 | \newenvironment{pfcodeblock}[1]{}{} 41 | \newcommand{\pfcodeblockbegin}{\begingroup\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=codeblock]} 42 | \newcommand{\pfcodeblockend}{\end{mdframed}\vskip1mm\endgroup} 43 | 44 | 45 | \definecolor{light-gray}{gray}{0.5} 46 | 47 | \begin{document} 48 | \setlength{\parindent}{0pt} 49 | 50 | \tableofcontents 51 | 52 | \newpage 53 | 54 | \newcommand*{\docpath}{../backend}% 55 | \input{\docpath/ssa-fold} 56 | 57 | \end{document} 58 | -------------------------------------------------------------------------------- /llvm-wrapper/Makefile: -------------------------------------------------------------------------------- 1 | PFRONT = pfront 2 | 3 | LLVMCONF:=llvm-config 4 | LLVMVER=$(shell $(LLVMCONF) --version) 5 | 6 | PWD = $(shell pwd) 7 | LLVMLIBS = $(shell $(LLVMCONF) --libs) 8 | LLVMINC = $(shell $(LLVMCONF) --includedir) 9 | LLVMALL = $(shell $(LLVMCONF) --ldflags) $(LLVMLIBS) 10 | 11 | CXX := clang++ 12 | CC := clang 13 | PYTHON := python 14 | 15 | MORELIBS := -lm 16 | 17 | CINDEXP := $(shell echo "import clang.cindex\nprint 'OK'" | $(PYTHON) 2> /dev/null) 18 | 19 | 20 | all: conf dll 21 | 22 | conf: lib/llvm-bindings.al 23 | 24 | ifeq (X$(CINDEXP), XOK) 25 | LSTDEPS := 26 | else 27 | LSTDEPS := llvm-bindings-lst-$(LLVMVER).al 28 | endif 29 | 30 | llvm-bindings-lst.al: $(LSTDEPS) 31 | ifeq (X$(CINDEXP), XOK) 32 | $(CC) -E $(shell $(LLVMCONF) --cppflags) ./llvm-stub.h -I $(LLVMINC) > llvm-bindings-E.c 33 | $(PYTHON) ./rebuild.py -std=c99 llvm-bindings-E.c > llvm-bindings-lst.al 34 | else 35 | cp llvm-bindings-lst-$(LLVMVER).al llvm-bindings-lst.al 36 | endif 37 | 38 | lib-conf.hl: 39 | echo "define llvm_libname = \"LLVM.so\";" > lib-conf.hl 40 | 41 | lib/llvm-bindings.al: llvm-bindings-lst.al 42 | mkdir -p lib 43 | ${PFRONT} ./tools/emit-mbase.hl > lib/llvm-bindings.al 44 | 45 | lib/llvm-wrapper.cpp: llvm-bindings-lst.al 46 | mkdir -p lib 47 | ${PFRONT} ./tools/emit-cpp.hl > lib/llvm-wrapper.cpp 48 | 49 | lib/llvm-wrapper.h: llvm-bindings-lst.al 50 | mkdir -p lib 51 | ${PFRONT} ./tools/emit-header.hl > lib/llvm-wrapper.h 52 | 53 | dll: conf lib-conf.hl lib/llvm-wrapper.cpp lib/llvm-wrapper.h lib/llvm-bindings.al 54 | echo $(LLVMPFX) 55 | echo $(LLVMALL) 56 | $(CXX) -shared -fPIC $(shell $(LLVMCONF) --cxxflags) -o lib/LLVM.so natnet2.c llvm-lib.cpp lib/llvm-wrapper.cpp $(LLVMALL) $(MORELIBS) 57 | 58 | clean: 59 | rm -rf lib/* 60 | -------------------------------------------------------------------------------- /llvm-wrapper/bindings/lib.hl: -------------------------------------------------------------------------------- 1 | #(ctimex (define debug-display-include-paths #t)) 2 | 3 | #(ctimex (begin 4 | (define assembly-version (S<< "0.1.0.0")) 5 | (define assembly-keyfile "lvmkey.snk") 6 | )) 7 | 8 | // #(n.module MBaseLLVM) 9 | 10 | #(macro define-enum-constant (nm . pairs) 11 | `(begin 12 | ,@(foreach-map (p pairs) 13 | `(define ,@p)))) 14 | 15 | 16 | 17 | define t_byte = #(dotnet "System.Byte"); 18 | 19 | include "../native/marshal.hl"; 20 | #(include "../lib/llvm-bindings.al"); 21 | include "./llvm.hl"; 22 | include "./llvm-ast.hl"; 23 | include "./llvm-emit.hl"; 24 | -------------------------------------------------------------------------------- /llvm-wrapper/bindings/llvm-ast.hl: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | AST is based on: 4 | http://llvm.org/docs/LangRef.html 5 | 6 | */ 7 | 8 | 9 | ast llvm_ir { 10 | 11 | irstructel is (irtype:t, irval:v); 12 | 13 | irtoplevel = 14 | %function(*ircallconv:cc, ident:name, irtype:ret, bool:va, *irarg:args, *irbblock:body, .*any:annotations) 15 | | eglobal(ident:name, irtype:type) 16 | | global(ident:name, irtype:type, irval:v) // v = const only! 17 | | comment(anything:x) 18 | ; 19 | 20 | ircode is (*irstmt:code); 21 | irbblock is (ident:name, .*irstmt:code); 22 | irarg is (irtype:type, ident:name); 23 | irlabel is (ident:nm); 24 | 25 | irval = 26 | false() 27 | | true() 28 | | null(irtype:t) 29 | | integer(int:v, .*ident:itp) 30 | | float(float:v, .*ident:ftp) 31 | | struct(. *irstructel:elts) 32 | | array(irtype:t, . *irval:elts) 33 | | vector(. *irval:elts) 34 | | zero(irtype:t) 35 | | undef(irtype:t) 36 | | blockaddress(ident:fn, ident:blk) 37 | | var(ident:nm) 38 | | global(ident:nm) 39 | | globalfun(ident:nm) 40 | | sizeof(irtype:t) 41 | ; 42 | 43 | irtype = 44 | integer(ident:type) 45 | | float(ident:ftype) 46 | | label() 47 | | void() 48 | | array(*int:dims, irtype:t, .*aspace:spc) 49 | | %function(irtype:ret, .*irtype:args) 50 | | varfunction(irtype:ret, .*irtype:args) 51 | | struct(ident:nm, . *irtype:elts) 52 | | structref(ident:nm) 53 | | packed(ident:nm, . *irtype:elts) 54 | | pointer(irtype:t, .*aspace:spc) 55 | | vector(int:n, irtype:t) 56 | | alias(ident:id) 57 | ; 58 | 59 | irstmt = /* More or less the same as terminal instructions, 60 | with 'store' moved here and 'invoke' moved to irexpr */ 61 | set(ident:nm, irexpr:e) 62 | | setstring(ident:nm, string:s) 63 | | ret(irval:value) 64 | | vret() 65 | | br(irval:cnd, irlabel:tr, irlabel:fl) 66 | | br_label(ident:nm) 67 | | switch(irval:value, irlabel:els, *irswitchdst:cases) 68 | | indirectbr(irsometype:t, irval:addr, *irlabel:ds) 69 | /* No invoke here, since it returns a value */ 70 | | unwind() 71 | | unreacheable() 72 | /* 'store' is a memory instruction, but it does not return any value */ 73 | | store(irval:ptr, irval:e) 74 | | volatile_store(irtype:t, irval:value, irtype:ty, irval:ptr, *irval:align) 75 | | label(ident:nm) 76 | 77 | ; 78 | 79 | irswitchdst is ( irval:value, irlabel:dst ); 80 | irphi is (irval:value, irlabel:dst); 81 | 82 | irexpr = 83 | binary(irbinop:op, irval:l, irval:r) 84 | | extractelement(int:n, irval:v, irval:idx) 85 | | insertelement(int:n, irtype:t, irval:v, irval:elt, irval:idx) 86 | | shufflevector(int:n1, irval:val1, int:n1, irval:val2, irval:mask) 87 | | extractvalue(iraggtype:t, irval:v, irval:idx) 88 | | insertvalue(irval:v, irtype:tv, irval:elt, irval:idx) 89 | | alloca(irtype:t) 90 | | load(irval:ptr) 91 | | getelementptr(irval:ptr, . *irval:idxs) 92 | | getelementptr_inbounds(irval:ptr, . *irval:idxs) 93 | | convop(irconvop:op, irval:v, irtype:t) 94 | | icmp(iricond:vcond, irval:lhs, irval:rhs) 95 | | fcmp(irfcond:vcond, irval:lhs, irval:rhs) 96 | | phi(irtype:t, .*irphi:dsts) 97 | | select(irval:vif, irval:vthen, irval:velse) 98 | | call(ident:fn, .*irval:args) 99 | | callptr(irval:fn, .*irval:args) 100 | | callptrstd(irval:fn, .*irval:args) 101 | | ptr(irval:src, irtype:dst) 102 | ; 103 | } 104 | -------------------------------------------------------------------------------- /llvm-wrapper/bindings/llvm-emit.hl: -------------------------------------------------------------------------------- 1 | 2 | function make_statement(bld,nm) 3 | fun(op, args) { args = [bld;@args;nm]; 4 | fn = llvm_get_opcode_s(op); 5 | return apply(fn, args) } 6 | 7 | function unzip(lst) 8 | { 9 | return cons(map(car,lst), map(cdr,lst)); 10 | } 11 | 12 | function i32toi64(val) { .net(val): (((System.IConvertible)val).ToInt64((System.IFormatProvider)null)); } 13 | 14 | function integer_type(type) 15 | case type { 16 | 'i32'|'int32' -> LLVM_Int32Type() 17 | | 'i16'|'int16' -> LLVM_Int16Type() 18 | | 'i8'|'int8' -> LLVM_Int8Type() 19 | | 'i64'|'int64' -> LLVM_Int64Type() 20 | | else -> LLVM_Int32Type() 21 | } 22 | 23 | function real_type(type) 24 | case type { 25 | 'float'|'f' -> LLVM_FloatType() 26 | | 'double'|'d' -> LLVM_DoubleType() 27 | | else -> LLVM_FloatType() 28 | } 29 | 30 | function llvm_get_or_create_struct(mdl, ph, nm) 31 | { 32 | chk = ph /@ nm; 33 | if(chk) chk else { 34 | tp = LLVM_StructCreateNamedS(LLVM_GetGlobalContext(), nm); 35 | ph/!nm <- tp; 36 | return tp 37 | } 38 | } 39 | 40 | function llvm_make_struct_type(mdl,ph,nm0,elts,pckp) 41 | { 42 | nch = %llvm-mdl-ph(mdl); 43 | nm = if(nm0) %S<<(nm0) else []; 44 | nchk = if(nm) nch/@nm; 45 | if(nchk) { 46 | if(LLVM_IsOpaqueStruct(nchk)!=0) { 47 | LLVM_StructSetBody(nchk, marshal_list(elts), length(elts), pckp); 48 | }; 49 | return nchk 50 | } else 51 | { 52 | tp = if(nm) llvm_get_or_create_struct(mdl, ph, nm) 53 | else LLVM_StructType(marshal_list(elts), length(elts), pckp); 54 | if(LLVM_IsOpaqueStruct(tp)!=0) { 55 | if(nm) LLVM_StructSetBody(tp, marshal_list(elts), length(elts), pckp); 56 | }; 57 | recp = if(nm) ph /@ nm; 58 | rettyp = tp; 59 | if(and(nm, not(%string=?(nm,"")))) { 60 | nch/!nm<-rettyp 61 | }; 62 | return rettyp 63 | } 64 | } 65 | 66 | function llvm_compile_type(mdl,typ) 67 | { 68 | strenv = %llvm-mdl-ph(mdl); 69 | visit:llvm_ir(irtype: typ) 70 | { 71 | deep irtype 72 | { 73 | | integer -> integer_type(type) 74 | | pointer -> LLVM_PointerType(t,0) 75 | | %function -> %llvm-function-type(ret, args, []) 76 | | varfunction -> %llvm-function-type(ret, args, true) 77 | | float -> real_type(ftype) 78 | | label -> LLVM_LabelType() 79 | | void -> LLVM_VoidType() 80 | | array -> LLVM_ArrayType(t, car(dims)) 81 | | struct -> 82 | llvm_make_struct_type(mdl,strenv,nm, elts,0) 83 | | structref -> { 84 | nch = %llvm-mdl-ph(mdl); 85 | nchk = if(nm) nch/@nm; 86 | if(nchk) nchk else 87 | { 88 | chk = strenv /@ nm; 89 | if(chk) chk else { 90 | phol = llvm_get_or_create_struct(mdl, strenv, nm); 91 | return phol 92 | }}} 93 | | alias -> 94 | LLVM_GetTypeByNameS(%llvm-mdl(mdl), %S<<(id)) 95 | | packed -> 96 | llvm_make_struct_type(mdl,strenv,nm,elts,1) 97 | | vector -> LLVM_VectorType(n, t) 98 | } 99 | } 100 | } 101 | 102 | function strlen(s) .net(s): ((string)s).get_Length() 103 | 104 | function llvm_compile_value(mdl, vars, val) 105 | visit:llvm_ir(irval: val) 106 | { 107 | deep irval 108 | { 109 | | integer -> { 110 | type = if(itp) car(itp) else 'i32'; 111 | LLVM_ConstInt(integer_type(type), i32toi64(v), 1) 112 | } 113 | | null -> LLVM_ConstNull (t) 114 | | float -> { 115 | type = if(ftp) car(ftp) else 'float'; 116 | LLVM_ConstRealOfStringS(real_type(type), v) 117 | } 118 | | struct -> LLVM_ConstStruct (marshal_list(elts), length(elts),0) 119 | | array -> LLVM_ConstArray (t, marshal_list(elts), length(elts)) 120 | | vector -> LLVM_ConstVector (marshal_list(elts), length(elts)) 121 | | zero -> LLVM_ConstNull (t) 122 | | undef -> LLVM_GetUndef (t) 123 | // | asm -> LLVM_ConstInlineAsmS (t, asm, constraints, sideeffects) 124 | | var -> hashget(vars, nm) 125 | | global -> LLVM_GetNamedGlobalS(%llvm-mdl(mdl),%S<<(nm)) 126 | | globalfun -> LLVM_GetNamedFunctionS(%llvm-mdl(mdl),%S<<(nm)) 127 | | sizeof -> LLVM_SizeOf(t) 128 | }; 129 | once irtype: forall llvm_compile_type(mdl,node); 130 | } 131 | 132 | function llvm_compile_expression(mdl, vars, bblocks, Inst, nm, ex) 133 | { 134 | visit:llvm_ir(irexpr: ex) 135 | { 136 | // irval nodes are already processed here, so we have 137 | // to block visitor from going deep into them: 138 | once irval: forall node; 139 | once irtype: forall llvm_compile_type(mdl,node); 140 | once irphi: cons(value, bblocks /@ dst); 141 | 142 | deep irexpr 143 | { 144 | | binary -> Inst(op, [l;r]) 145 | | extractelement -> Inst('ExtractElement',[v; idx]) 146 | | insertelement -> Inst('InsertElement', [v; elt; idx]) 147 | | shufflevector -> Inst('ShuffleVector', [val1; val2; mask]) 148 | | extractvalue -> Inst('ExtractValue', [v; idx]) 149 | | insertvalue -> Inst('InsertValue', [v; elt; idx]) 150 | | alloca -> { i = Inst('Alloca', [t]); vars /! nm <- i; i; } 151 | | load -> Inst('Load', [ptr]) 152 | | getelementptr_inbounds 153 | -> 154 | Inst('InBoundsGEP', 155 | [ptr; 156 | marshal_list(idxs); 157 | length(idxs)]) 158 | | getelementptr 159 | -> Inst('GEP', 160 | [ptr; 161 | marshal_list(idxs); 162 | length(idxs)]) 163 | | convop -> Inst(op, [v; t]) 164 | | icmp -> Inst('ICmp', [llvm_v(LLVMInt,vcond); lhs; rhs]) 165 | | fcmp -> Inst('FCmp', [llvm_v(LLVMReal,vcond); lhs; rhs]) 166 | | phi -> { 167 | ph = Inst('Phi', [t]); 168 | temp = unzip(dsts); 169 | LLVM_AddIncoming(ph, marshal_list(car(temp)), marshal_list(cdr(temp)), length(temp)); 170 | ph; 171 | } 172 | | select -> Inst('Select', [vif; vthen; velse]) 173 | | call -> Inst('Call', [LLVM_GetNamedFunctionS(%llvm-mdl(mdl), fn); marshal_list(args); length(args)]) 174 | | callptr -> Inst('Call', [fn; marshal_list(args); length(args)]) 175 | | callptrstd -> {c = Inst('Call', [fn; marshal_list(args); length(args)]); LLVM_SetInstructionCallConv(c, LLVMX86FastcallCallConv); return c;} 176 | }; 177 | }; 178 | } 179 | 180 | function add_switch_case(s, bblocks, c) 181 | { 182 | <[v;dstnm]> = c; 183 | LLVM_AddCase(s, v, bblocks /@ dstnm); 184 | } 185 | 186 | 187 | function llvm_compile_toplevel(mdl, bld, toplevel) 188 | with hash (vars, bblocks) 189 | { 190 | visit_stmt = fun(stmt) { 191 | visit:llvm_ir(irstmt:stmt) 192 | { 193 | deep irval: forall llvm_compile_value(mdl, vars,node); 194 | deep irstmt 195 | { 196 | | set -> 197 | { 198 | Inst = make_statement(bld, nm); 199 | vl = llvm_compile_expression(mdl, vars, bblocks, Inst, nm, e); 200 | if(and(nm,not(%string=?(%S<<(nm),"")))) { 201 | vars /! nm <- vl; 202 | }; 203 | return []; 204 | } 205 | | setstring -> { 206 | nms = %S<<(nm); 207 | v = (llvm_get_opcode_s('GlobalStringPtr'))(bld, s, nms); 208 | vars /! nms <- v; 209 | [] 210 | } 211 | | ret -> (llvm_get_opcode('Ret'))(bld, value) 212 | | vret -> (llvm_get_opcode('RetVoid'))(bld) 213 | | br_label -> (llvm_get_opcode('Br'))(bld, bblocks /@ nm) 214 | | br -> (llvm_get_opcode('CondBr'))(bld, cnd, bblocks /@ tr, bblocks /@ fl) 215 | | switch -> {s = (llvm_get_opcode('Switch'))(bld,value,bblocks /@ els, length(cases)); iter c in cases do add_switch_case(s, bblocks, c); return s;} 216 | | store -> { 217 | i = (llvm_get_opcode('Store'))(bld, e, ptr); i } 218 | | else -> ccerror(#`(STATEMENT ,node)) 219 | }; 220 | } 221 | }; 222 | 223 | // first pass 224 | func = visit:llvm_ir(irtoplevel: toplevel) 225 | { 226 | once irbblock: { 227 | fun (func) 228 | { 229 | b = LLVM_AppendBasicBlockS(func, name); 230 | bblocks /! name <- b; 231 | }; 232 | }; 233 | deep irtoplevel 234 | { 235 | %function -> { 236 | ftype = if(va) 'varfunction' else 'function'; 237 | type = [ftype;ret;@map(car, args)]; 238 | func = %llvm-add-function(mdl, %symbol->string(name), 239 | llvm_compile_type(mdl,type)); 240 | iter cc do (match cc with 241 | 'stdcall' -> 242 | LLVM_SetFunctionCallConv(func, 243 | LLVMX86FastcallCallConv) 244 | ); 245 | params = %llvm-get-params(func); 246 | iter [p;nmm] in zip(params, map(cadr,args)) do { 247 | n = %S<<(nmm); 248 | LLVM_SetValueNameS(p, n); 249 | vars /! n <- p; 250 | }; 251 | iter body do body(func); 252 | return if(body) func else []; 253 | } 254 | | global -> { 255 | gtype = llvm_compile_type(mdl,type); 256 | ptr = LLVM_AddGlobalS(%llvm-mdl(mdl), gtype, name); 257 | LLVM_SetLinkage(ptr, LLVMInternalLinkage); 258 | LLVM_SetInitializer(ptr, 259 | llvm_compile_value(mdl, mkhash(), v)); 260 | return [] 261 | } 262 | | eglobal -> { 263 | gtype = llvm_compile_type(mdl,type); 264 | ptr = LLVM_AddGlobalS(%llvm-mdl(mdl), gtype, name); 265 | LLVM_SetLinkage(ptr, LLVMExternalLinkage); 266 | return [] 267 | } 268 | | else -> [] 269 | }; 270 | }; 271 | 272 | iter:llvm_ir(irtoplevel: toplevel) 273 | { 274 | deep irbblock: { 275 | LLVM_PositionBuilderAtEnd(bld, (bblocks /@ name)); 276 | iter code do visit_stmt(code); 277 | } 278 | }; 279 | return func; 280 | } 281 | 282 | define llvm_initp = mkref(nil); 283 | 284 | function llvm_init_module(name) 285 | { 286 | if(not(deref(llvm_initp))) { 287 | %_LLVMInitializeNativeTarget(); 288 | %_LLVMInitializeNativeAsmPrinter(); 289 | %_LLVMLinkInMCJIT(); 290 | %_LLVMLinkInInterpreter(); 291 | %r!(llvm_initp, true); 292 | }; 293 | %llvm-init-module(name); 294 | } 295 | 296 | function llvm_emit_inner(mdl, past) 297 | { 298 | bld = %llvm-create-builder(); 299 | foo = llvm_compile_toplevel(mdl, bld, past); 300 | LLVM_DisposeBuilder(bld); 301 | if(foo) { 302 | <[bld;pm;fpm]> = %llvm-mdl-fpm(mdl); 303 | if(fpm) LLVM_RunFunctionPassManager(fpm, foo); 304 | if(not(deref(llvm_no_engine))) { 305 | return fun() 306 | LLVM_GetPointerToGlobal(%llvm-mdl-ee(mdl), foo) 307 | } 308 | } 309 | } 310 | 311 | function llvm_emit(mdl, past) 312 | { 313 | try llvm_emit_inner(mdl, past) 314 | catch (t_MBaseException e) { 315 | println("Error while emiting the toplevel LLVM code"); 316 | println(mbaseerror(e)); 317 | return [] 318 | } 319 | } 320 | 321 | function llvm_save(mdl, fname) 322 | { 323 | %llvm-run-pass-manager(mdl); 324 | LLVM_WriteBitcodeToFileS(%llvm-mdl(mdl), fname); 325 | } 326 | 327 | function llvm_debug(mdl) 328 | { 329 | %llvm-run-pass-manager(mdl); 330 | LLVM_WriteBitcodeToFileS(%llvm-mdl(mdl), "test.o"); 331 | LLVM_DumpModule(%llvm-mdl(mdl)); 332 | } 333 | 334 | 335 | 336 | 337 | -------------------------------------------------------------------------------- /llvm-wrapper/bindings/llvm.hl: -------------------------------------------------------------------------------- 1 | #(macro type-case (t . args) 2 | (with-syms (s) 3 | `(alet ,s (r_GetType ,t) 4 | (cond ,@(foreach-map (a args) 5 | (if (eqv? (car a) 'else) a 6 | `((t_eq ,s ,(car a)) 7 | (begin ,@(cdr a))))))))) 8 | 9 | #(function llvm-mdl (mdl) (format mdl (m prov ee fpm) m)) 10 | #(function llvm-mdl-prov (mdl) (format mdl (m prov ee fpm) prov)) 11 | #(function llvm-mdl-ee (mdl) (format mdl (m prov ee fpm) ee)) 12 | #(function llvm-mdl-fpm (mdl) (format mdl (m prov ee fpm) fpm)) 13 | #(function llvm-mdl-ph (mdl) (format mdl (m prov ee fpm mpm ph) ph)) 14 | 15 | #(macro llvm_prefix (prefix x) 16 | `(alet res (( "LLVM_" ,prefix _ ?) (string->list ,x)) 17 | (cons (p-success? res) (list->string (p-rest res))))) 18 | 19 | #(define llvm_no_engine (mkref nil)) 20 | 21 | define LLVM_T = #(ctime 22 | `(n.asm () 23 | (Ldtoken ,t_Meta.LLVMW) 24 | (Call ,(r_mtd "System.Type" "GetTypeFromHandle" "System.RuntimeTypeHandle")) 25 | (Castclass ,t_object))); 26 | -------------------- 27 | 28 | function %get-build-funcs() 29 | { 30 | lst0 = %a->l(%_getmembers( LLVM_T )); 31 | fe = getfuncenv(); 32 | build_funcs=mkhash(); 33 | iter lst0 do 34 | if(%t_ass?(t_MethodInfo,r_GetType(lst0))) { 35 | mn = %_getmtdname(lst0); 36 | res = llvm_prefix("Build", mn); 37 | if(car(res)) { 38 | build_funcs /! cdr(res) <- shashget(fe, %Sm<<(mn)); 39 | n1 = %Sm<<(mn,"S"); 40 | c1 = shashget(fe, n1); 41 | if(c1) build_funcs /! %S<<(cdr(res),"S") <- c1; 42 | } 43 | }; 44 | return build_funcs; 45 | } 46 | 47 | define llvm_opcodes = %get-build-funcs(); 48 | 49 | --------------------------------------------------------- 50 | #(force-class-flush) 51 | 52 | function %llvm-create-module (name) 53 | LLVM_ModuleCreateWithNameS(name) 54 | 55 | function %llvm-create-module-provider (mdl) 56 | LLVM_CreateModuleProviderForExistingModule(mdl) 57 | 58 | function %llvm-create-execution-engine (moduleprovider) 59 | %_LLVMCreateExecutionEngine(moduleprovider) 60 | 61 | define %llvm-optimise = mkref(true) 62 | 63 | function %llvm-init-module(nm) 64 | { 65 | mdl = %llvm-create-module(nm); 66 | mdlprov = %llvm-create-module-provider(mdl); 67 | ee = if(not(deref(llvm_no_engine))) 68 | %_LLVMCreateExecutionEngine(mdlprov); 69 | eetd = if(ee) LLVM_GetExecutionEngineTargetData(ee); 70 | 71 | %_InitMCJIT(ee, mdl); 72 | 73 | fpm = if(deref( %llvm-optimise )) { 74 | bldr = LLVM_PassManagerBuilderCreate(); 75 | pm = LLVM_CreatePassManager(); 76 | fpm = LLVM_CreateFunctionPassManagerForModule(mdl); 77 | // if (eetd) LLVM_AddTargetData(eetd,pm); 78 | LLVM_PassManagerBuilderSetOptLevel(bldr, LLVMCodeGenLevelAggressive); 79 | 80 | LLVM_AddFunctionInliningPass(pm); 81 | 82 | LLVM_AddCFGSimplificationPass(fpm); 83 | LLVM_AddPromoteMemoryToRegisterPass(fpm); 84 | LLVM_AddInstructionCombiningPass(fpm); 85 | LLVM_AddEarlyCSEPass(fpm); 86 | LLVM_AddTailCallEliminationPass(fpm); 87 | LLVM_AddConstantPropagationPass(fpm); 88 | LLVM_AddInstructionCombiningPass(fpm); 89 | 90 | LLVM_PassManagerBuilderPopulateModulePassManager(bldr, pm); 91 | LLVM_PassManagerBuilderPopulateFunctionPassManager(bldr, fpm); 92 | 93 | LLVM_InitializeFunctionPassManager(fpm); 94 | return [bldr;pm;fpm]; 95 | } else [[];[];[]]; 96 | return [mdl; mdlprov; ee; fpm; []; mkhash()] 97 | } 98 | 99 | function %llvm-run-pass-manager (mdl) 100 | { 101 | <[bld;pm;fpm]> = %llvm-mdl-fpm(mdl); 102 | // if(pm) LLVM_RunPassManager(pm, %llvm-mdl(mdl)); 103 | } 104 | 105 | function %llvm-type (tp) 106 | #(type-case tp 107 | (t_Int32 (LLVM_Int32Type)) 108 | (else (println (S<< "LLVM unsuported type: " tp)))) 109 | 110 | 111 | function %llvm-function-type (rettype, args, vararg) 112 | LLVM_FunctionType(rettype, 113 | marshal_list(args), 114 | length(args), 115 | if(vararg) 1 else 0) 116 | 117 | function %llvm-get-params (func) 118 | { 119 | n = LLVM_CountParams(func); 120 | map i in [0..n] do { 121 | LLVM_GetParam(func, i); 122 | } 123 | } 124 | 125 | 126 | function %llvm-add-function (mdl, name, ftype) 127 | LLVM_AddFunctionS(%llvm-mdl(mdl),name,ftype) 128 | 129 | function %llvm-create-builder () LLVM_CreateBuilder() 130 | 131 | function %llvm-get-function (mdl, name) 132 | LLVM_GetNamedFunctionS(%llvm-mdl(mdl), name) 133 | 134 | function %llvm-build-ret-void (bld) 135 | LLVM_BuildRetVoid(bld) 136 | 137 | function %llvm-run-function (mdl, func) 138 | %_LLVMRunFunction(%llvm-mdl-ee(mdl), func) 139 | 140 | function %llvm-const-int(val) 141 | LLVM_ConstInt(LLVM_Int32Type(), 142 | .net(val): ((System.IConvertible)val). 143 | ToInt64((System.IFormatProvider)null),1) 144 | 145 | 146 | function test_op(x) 147 | .net(x): System.Globalization.CultureInfo. 148 | get_CurrentCulture().get_TextInfo(). 149 | ToTitleCase((System.String)x) 150 | 151 | function llvm_get_opcode_s(x) 152 | { 153 | str = %S<<(%symbol->string(x),"S"); 154 | ret = llvm_opcodes /@ str; 155 | if(ret) ret else {println(#`(UNKNOWN STR INSTRUCTION ,x)); []} 156 | } 157 | 158 | 159 | function llvm_get_opcode(x) 160 | { 161 | str = %symbol->string(x); 162 | ret = llvm_opcodes /@ str; 163 | if(ret) ret else {println(#`(UNKNOWN INSTRUCTION ,x)); []} 164 | } 165 | 166 | function invoke_native_func(func, args) return InvokeNativeFunction(func, length(args), marshal_list(args)) 167 | 168 | function llvm_vf(pfx, vlu) 169 | #(shashget (getfuncenv) (Sm<< pfx vlu)) 170 | 171 | #(macro llvm_v (pfx vlu) 172 | `(llvm_vf (quote ,pfx) ,vlu)) 173 | 174 | 175 | function llvm_force_exit() [] // %_exit(0) 176 | ///// The following does not work :( 177 | 178 | #(macro llvm_make_invoker (rtype . argtypes) ;; value types/intptrs only 179 | (let ((args =pf: map a in argtypes count i do %Sm<<("aa",i))) 180 | `(fun (ptr ,@args) 181 | (n.asm (ptr ,@args) 182 | ,@(foreach-mappend (z (reverse (zip argtypes args))) 183 | (format z (t0 a) 184 | (alet t (read-int-eval t0) 185 | `( 186 | (expr ,a) 187 | (Unbox ,t) 188 | ,(_ldind t) 189 | )))) 190 | (expr ptr) 191 | (Unbox ,t_IntPtr) 192 | (Ldind_I) 193 | (Calli (,=pf: .net: System.Runtime.InteropServices.CallingConvention.Winapi) ,(read-int-eval rtype) ,(map read-int-eval argtypes) ()) 194 | (Box ,(read-int-eval rtype)) 195 | )))) 196 | 197 | -------------------------------------------------------------------------------- /llvm-wrapper/llvm-bindings-list.al: -------------------------------------------------------------------------------- 1 | #(read-int-eval '(include "./llvm-bindings-lst.al")) 2 | 3 | -------------------------------------- 4 | #(force-class-flush) 5 | -------------------------------------------------------------------------------- /llvm-wrapper/llvm-lib.cpp: -------------------------------------------------------------------------------- 1 | #include "llvm-wrapper-base.h" 2 | #include "llvm-c/Analysis.h" 3 | #include "llvm-c/BitReader.h" 4 | #include "llvm-c/BitWriter.h" 5 | #include "llvm-c/Core.h" 6 | #include "llvm-c/ExecutionEngine.h" 7 | #include "llvm-c/LinkTimeOptimizer.h" 8 | #include "llvm-c/Target.h" 9 | #include "llvm-c/Transforms/IPO.h" 10 | #include "llvm-c/Transforms/Scalar.h" 11 | #include 12 | #include 13 | #include "llvm/ExecutionEngine/ExecutionEngine.h" 14 | 15 | extern "C" DLL_EXPORT int _LLVMInitializeNativeTarget(); 16 | extern "C" DLL_EXPORT int _LLVMInitializeNativeAsmPrinter(); 17 | extern "C" DLL_EXPORT void _LLVMLinkInInterpreter() { LLVMLinkInInterpreter(); } 18 | extern "C" DLL_EXPORT void _LLVMLinkInMCJIT() { LLVMLinkInMCJIT(); } 19 | 20 | extern "C" DLL_EXPORT LLVMModuleRef _LLVMModuleCreateWithName(const char *ModuleID) { return LLVMModuleCreateWithName(ModuleID); } 21 | extern "C" DLL_EXPORT LLVMExecutionEngineRef _LLVMCreateExecutionEngine(LLVMModuleRef MP) 22 | { 23 | char* error; 24 | LLVMExecutionEngineRef EE = NULL; 25 | LLVMCreateExecutionEngineForModule(&EE,MP,&error); 26 | return EE; 27 | } 28 | extern "C" DLL_EXPORT LLVMGenericValueRef _LLVMRunFunction(LLVMExecutionEngineRef EE, LLVMValueRef F) 29 | { 30 | LLVMGenericValueRef t; 31 | return LLVMRunFunction(EE, F,0, &t); 32 | } 33 | 34 | extern "C" DLL_EXPORT int _InitMCJIT(LLVMExecutionEngineRef EE, LLVMModuleRef M) { 35 | LLVMMCJITCompilerOptions Opts; 36 | LLVMInitializeMCJITCompilerOptions(&Opts, sizeof(Opts)); 37 | Opts.OptLevel = 2; 38 | LLVMCreateMCJITCompilerForModule(&EE, M, &Opts, sizeof(Opts), 0); 39 | return 0; 40 | } 41 | 42 | 43 | extern "C" DLL_EXPORT void * _LLVMGetGlobalValueAddress(LLVMExecutionEngineRef EE, LLVMValueRef F) { 44 | llvm::unwrap(EE)->finalizeObject(); 45 | 46 | return (void *)(llvm::unwrap(EE)->getGlobalValueAddress(llvm::unwrap(F)->getName())); 47 | } 48 | 49 | int _LLVMInitializeNativeTarget() 50 | { 51 | LLVMInitializeNativeTarget(); 52 | return 0; 53 | 54 | } 55 | 56 | int _LLVMInitializeNativeAsmPrinter() 57 | { 58 | LLVMInitializeNativeAsmPrinter(); 59 | return 0; 60 | 61 | } 62 | 63 | extern "C" DLL_EXPORT int _InvokeFunc0(int (*ptr)()) 64 | { 65 | return ptr(); 66 | } 67 | 68 | extern "C" DLL_EXPORT int _InvokeFunc1(int (*ptr)(int), int a) 69 | { 70 | if (NULL == ptr) { 71 | printf("NULL WTF\n"); 72 | return 0; 73 | } 74 | return ptr(a); 75 | } 76 | 77 | extern "C" DLL_EXPORT int _InvokeFunc1p(int (*ptr)(void *), void *a) 78 | { 79 | return ptr(a); 80 | } 81 | 82 | 83 | extern "C" DLL_EXPORT int _InvokeFunc2(int (*ptr)(int,int), int a, int b) 84 | { 85 | return ptr(a,b); 86 | } 87 | 88 | extern "C" DLL_EXPORT int _InvokeFunc2p(int (*ptr)(void*, void*), void* a, void* b) 89 | { 90 | return ptr(a,b); 91 | } 92 | 93 | extern "C" DLL_EXPORT int invoke_piii(int (*ptr)(void*, int,int,int), void* p, int a, int b, int c) 94 | { 95 | return ptr(p, a,b,c); 96 | } 97 | 98 | extern "C" DLL_EXPORT int invoke_pp(int (*ptr)(void*, void*), void* a, void* b) 99 | { 100 | return ptr(a,b); 101 | } 102 | 103 | // I don't know how to do this portably 104 | extern "C" DLL_EXPORT int InvokeNativeFunction(int (*ptr)(), int nargs, void** args) 105 | { 106 | return ptr(); 107 | } 108 | 109 | 110 | extern "C" DLL_EXPORT void print_array(int* arr) 111 | { 112 | printf("Array is:\n"); 113 | for(int i=0; i<3; i++) 114 | { 115 | printf("%d ", arr[i]); 116 | } 117 | printf("\n"); 118 | } 119 | -------------------------------------------------------------------------------- /llvm-wrapper/llvm-stub.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include "llvm-c/Analysis.h" 3 | #include "llvm-c/BitReader.h" 4 | #include "llvm-c/BitWriter.h" 5 | #include "llvm-c/Core.h" 6 | #include "llvm-c/ExecutionEngine.h" 7 | #include "llvm-c/LinkTimeOptimizer.h" 8 | #include "llvm-c/Target.h" 9 | #include "llvm-c/TargetMachine.h" 10 | #include "llvm-c/Transforms/IPO.h" 11 | #include "llvm-c/Transforms/Scalar.h" 12 | #include "llvm-c/Transforms/PassManagerBuilder.h" 13 | -------------------------------------------------------------------------------- /llvm-wrapper/llvm-wrapper-base.h: -------------------------------------------------------------------------------- 1 | #ifdef WIN32 2 | #define DLL_EXPORT __declspec(dllexport) 3 | #else 4 | #define DLL_EXPORT 5 | #endif 6 | 7 | #define __STDC_LIMIT_MACROS 8 | #define __STDC_CONSTANT_MACROS 9 | 10 | #include "llvm-stub.h" 11 | -------------------------------------------------------------------------------- /llvm-wrapper/native/marshal.hl: -------------------------------------------------------------------------------- 1 | define NULL = .net: IntPtr.Zero; 2 | 3 | --------------------------------------------------- 4 | #(force-class-flush) 5 | 6 | ----------------------- 7 | 8 | function marshal_str(str0) 9 | { 10 | if(str0) { 11 | str = %any->string(str0); 12 | notnet(System.String str) { leave System.Runtime.InteropServices.Marshal.StringToHGlobalAnsi(str); } 13 | } else .net: System.IntPtr.Zero; 14 | } 15 | 16 | #(force-class-flush) 17 | ------------------------------ 18 | 19 | function marshal_list(l) 20 | { 21 | if ( %null?(l)) .net: System.IntPtr.Zero; 22 | else if (%list?(l)) 23 | { 24 | fst = car(l); 25 | sizeof = .net(fst): System.Runtime.InteropServices.Marshal.SizeOf(fst); 26 | num = length(l); 27 | len = sizeof * num; 28 | pt = notnet(int len) { leave System.Runtime.InteropServices.Marshal.AllocHGlobal(len); }; 29 | iter l count i do 30 | { 31 | notnet(int sizeof, System.IntPtr pt, System.Object l, int i) 32 | { 33 | if ( typeof(l) == Type.GetType("System.IntPtr")) 34 | System.Runtime.InteropServices.Marshal.WriteIntPtr(pt, i*sizeof, (System.IntPtr)l); 35 | else if ( typeof(l) == Type.GetType("System.Int32")) 36 | System.Runtime.InteropServices.Marshal.WriteInt32(pt, i*sizeof, (System.Int32)l); 37 | leave null; 38 | }; 39 | }; 40 | return pt; 41 | } else .net: System.IntPtr.Zero; 42 | } 43 | 44 | 45 | #(force-class-flush) 46 | -------------------------------- 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /llvm-wrapper/natnet2.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef void* net_ptr; 4 | typedef net_ptr (*net_fun)(...); 5 | typedef int net_handle; 6 | typedef unsigned char byte; 7 | typedef byte* byte_ptr; 8 | typedef long long bword; 9 | 10 | typedef struct 11 | { 12 | } net_vtab_entry_t; 13 | 14 | bword net_get_val(byte_ptr loc, int wsize) 15 | { 16 | bword val = 0; 17 | // reversed order 18 | for(int b=wsize-1; b>=0; b--) 19 | val = (val << 8) | loc[b]; 20 | return val; 21 | } 22 | 23 | extern "C" void net_dump(net_ptr loc, int wsize, int nwords, int ncols) 24 | { 25 | byte_ptr loc1 = (byte_ptr)loc; 26 | for(int i=0; i=0; b--) 33 | printf("%x", ((byte_ptr)&val)[b]); 34 | } 35 | } 36 | 37 | 38 | -------------------------------------------------------------------------------- /llvm-wrapper/rebuild.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | 4 | import sys 5 | import clang.cindex 6 | 7 | fcache = {} 8 | 9 | def sanitise(tp): 10 | return tp.replace("[]","*") 11 | 12 | def find_arguments(args): 13 | NNN=0 14 | for a in args: 15 | argnm = a.spelling 16 | if argnm=="": 17 | argnm = 'A'+str(NNN) 18 | NNN = NNN + 1 19 | print ' ("%s" "%s")' % (argnm, sanitise(a.type.spelling)) 20 | 21 | def find_functions(node): 22 | if node.kind == clang.cindex.CursorKind.FUNCTION_DECL: 23 | nm = node.spelling 24 | if not(nm in fcache): 25 | fcache[nm] = nm 26 | if node.spelling.startswith('LLVM'): 27 | print ' ("%s" "%s" (' % (node.spelling, sanitise(node.result_type.spelling)) 28 | find_arguments(node.get_arguments()) 29 | print ' ))' 30 | else: 31 | for c in node.get_children(): 32 | find_functions(c) 33 | 34 | def parse_functions(): 35 | index = clang.cindex.Index.create() 36 | tu = index.parse(None, sys.argv) 37 | print '(define llvm-bindings-lst (quote (' 38 | find_functions(tu.cursor) 39 | print ')))' 40 | 41 | 42 | #----------------------- 43 | 44 | def find_enum_consts(c): 45 | if c.kind == clang.cindex.CursorKind.ENUM_CONSTANT_DECL: 46 | print ' ("%s" %d)' % (c.spelling, c.enum_value) 47 | 48 | def find_enums_inner(name, node): 49 | if node.kind == clang.cindex.CursorKind.ENUM_DECL: 50 | print ' ("%s" "%s" (' % (name, sanitise(node.enum_type.spelling)) 51 | for c in node.get_children(): 52 | find_enum_consts(c) 53 | print ' ))' 54 | 55 | def find_enums(node): 56 | if node.kind == clang.cindex.CursorKind.TYPEDEF_DECL: 57 | if node.spelling.startswith('LLVM'): 58 | for c in node.get_children(): 59 | find_enums_inner(node.spelling, c) 60 | else: 61 | for c in node.get_children(): 62 | find_enums(c) 63 | 64 | 65 | def parse_enums(): 66 | index = clang.cindex.Index.create() 67 | tu = index.parse(None, sys.argv) 68 | print '(define llvm-enums-lst (quote (' 69 | find_enums(tu.cursor) 70 | print ')))' 71 | 72 | 73 | parse_enums() 74 | parse_functions() 75 | -------------------------------------------------------------------------------- /llvm-wrapper/tools/emit-cpp.hl: -------------------------------------------------------------------------------- 1 | include "../llvm-bindings-list.al"; 2 | 3 | #(function filter_llvm (x) (( "LLVM" _ ?) (string->list x))) 4 | #(function mangle_llvm (nm) (S<< "LLVM_" (list->string (p-rest (filter_llvm (S<< nm)))))) 5 | 6 | function main() 7 | { 8 | println("#include \"llvm-wrapper.h\""); 9 | iter ([nm;tp;args]) in %llvm-bindings-lst do { 10 | body = %S<<(" return ", nm, "(", strinterleave(map ([pnm;ptp]) in args do pnm, ", "), ");"); 11 | println(%S<<( tp, " ", mangle_llvm(nm), 12 | "(", strinterleave(map ([pnm;ptp]) in args do %S<<(ptp, " ", pnm), ", "), ") {", body, "}")) 13 | } 14 | } 15 | 16 | main() -------------------------------------------------------------------------------- /llvm-wrapper/tools/emit-header.hl: -------------------------------------------------------------------------------- 1 | include "../llvm-bindings-list.al"; 2 | 3 | #(define export_prefix (S<< "extern " #\" "C" #\" " DLL_EXPORT")) 4 | 5 | #(function filter_llvm (x) (( "LLVM" _ ?) (string->list x))) 6 | #(function mangle_llvm (nm) (S<< "LLVM_" (list->string (p-rest (filter_llvm (S<< nm)))))) 7 | 8 | function main() { 9 | println("#include \"../llvm-wrapper-base.h\""); 10 | 11 | iter ([nm;tp;args]) in %llvm-bindings-lst do { 12 | println(%S<<( export_prefix , " ", tp, " ", mangle_llvm(nm), 13 | "(", strinterleave(map ([pnm;ptp]) in args do %S<<(ptp, " ", pnm), ", "), ");")) 14 | } 15 | } 16 | 17 | main() 18 | 19 | 20 | -------------------------------------------------------------------------------- /llvm-wrapper/tools/emit-mbase.hl: -------------------------------------------------------------------------------- 1 | include "../llvm-bindings-list.al"; 2 | 3 | #(define export_prefix (S<< "extern " #\" "C" #\" " DLL_EXPORT")) 4 | 5 | #(function filter_llvm (x) (( "LLVM" _ ?) (string->list x))) 6 | #(function mangle_llvm (nm) (S<< "LLVM_" (list->string (p-rest (filter_llvm (S<< nm)))))) 7 | #(define enumshsh (mkhash)) 8 | #(function llvm_typeof (l) 9 | (cond ((eq? "const char *" l) 't_string) 10 | ((eq? "char *" l) 't_string) 11 | ((eq? "const int" l) 't_int) 12 | ((eq? "unsigned int" l) 't_int) 13 | ((eq? "const unsigned int" l) 't_int) 14 | ((eq? "uint8_t" l) 't_byte) 15 | ((eq? "int" l) 't_int) 16 | ((eq? "const long long" l) 't_int64) 17 | ((eq? "unsigned long long" l) 't_int64) 18 | ((eq? "const unsigned long long" l) 't_int64) 19 | ((eq? "void" l) 't_void) 20 | ((eq? "LLVMBool" l) 't_int) 21 | ((hashget enumshsh l) 't_int) 22 | (else 't_intptr))) 23 | 24 | function strtypes(tp) 25 | map t in tp do match t with 't_string' -> 't_intptr' | else -> t 26 | 27 | function main() 28 | collector(stradd, strget) 29 | collector(add, get) { 30 | llvm_libname = "LLVM.so"; 31 | enums_constants=map ([nm;tp;cs]) in %llvm-enums-lst do { 32 | ohashput(enumshsh, nm, llvm_typeof(tp)); 33 | 'define-enum-constant'(%Sm<<(nm), 34 | @map ([cnm;cid]) in cs do [%Sm<<(cnm);cid]) 35 | }; 36 | #(begin 37 | ;; (add (S<< "(import \"libc.so.6\" \"_exit\" t_intptr t_int)")) 38 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_LLVMCreateExecutionEngine" #\" " " "t_intptr t_intptr)")) 39 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_LLVMRunFunction" #\" " t_intptr t_intptr t_intptr)")) 40 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_InvokeFunc0" #\" " t_intptr t_intptr)")) 41 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_InvokeFunc1" #\" " t_intptr t_intptr t_int)")) 42 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_InvokeFunc1p" #\" " t_intptr t_intptr t_intptr)")) 43 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_InvokeFunc2" #\" " t_intptr t_intptr t_int t_int)")) 44 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "invoke_piii" #\" " t_intptr t_intptr t_int t_int t_int)")) 45 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "invoke_pp" #\" " t_intptr t_intptr t_intptr)")) 46 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "InvokeNativeFunction" #\" " t_intptr t_intptr t_int t_intptr)")) 47 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_LLVMLinkInInterpreter" #\" " t_void)")) 48 | (add (S<< "(import " #\" llvm_libname #\" " " #\" "_LLVMLinkInMCJIT" #\" " t_void)")) 49 | (add (S<< "(import " #\" llvm_libname #\" " " #\""_LLVMInitializeNativeTarget" #\" " t_void)")) 50 | (add (S<< "(import " #\" llvm_libname #\" " " #\""_LLVMInitializeNativeAsmPrinter" #\" " t_void)")) 51 | (add (S<< "(import " #\" llvm_libname #\" " " #\""_LLVMGetGlobalValueAddress" #\" " t_intptr t_intptr t_intptr)")) 52 | (add (S<< "(import " #\" llvm_libname #\" " " #\""_InitMCJIT" #\" " t_int t_intptr t_intptr)")) 53 | ); 54 | iter ([nm;tp;args]) in %llvm-bindings-lst do { 55 | fnm = mangle_llvm(nm); 56 | pt = map ([an; at]) in args do llvm_typeof(at); 57 | add(%S<<("(import \"", llvm_libname, "\" \"", fnm, "\" ", 58 | strinterleave(strtypes(llvm_typeof(tp): pt), " "), 59 | ")")); 60 | if(filter(fun(t) t==='t_string', pt)) { 61 | xargs = map pt count i do %Sm<<("a_", i); 62 | stradd(%S<<(#`(function ,(Sm<< fnm "S") 63 | ,xargs 64 | (,(Sm<< fnm) 65 | ,@(foreach-map (x (zip xargs pt)) 66 | (format x (a t) 67 | (case t 68 | ((t_string) 69 | `(marshal_str ,a)) 70 | (else a)))))))) 71 | }; 72 | }; 73 | #(begin 74 | (foreach (i enums_constants) 75 | (println i)) 76 | (println '(ctime (define t_intptr (r_typebyname "System.IntPtr")))) 77 | (println '(ctime (define t_int64 (r_typebyname "System.Int64")))) 78 | (println "(ctime (define t_void (r_typebyname \"System.Void\")))") 79 | (println "(ctime (define t_string (r_typebyname \"System.String\")))") 80 | (println "(native (classname Meta.LLVMW)") 81 | (iter println (get)) 82 | (println ")") 83 | (println "(force-class-flush)") 84 | (println "(begin") 85 | (iter println (strget)) 86 | (println ")") 87 | ); 88 | } 89 | 90 | main() -------------------------------------------------------------------------------- /lvmkey.snk: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/combinatorylogic/clike/c0b3864962f5f8c2b2c5418ae3822748e3942fe6/lvmkey.snk -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # CLike 0.1 2 | 3 | CLike 0.1 is a low-level programming language with an extensible syntax based on C. It is supposed to be used as both a front-end and a target for MBase/PFront, and can be embedded as a JIT engine into .net applications. 4 | 5 | CLike targets LLVM, tested with LLVM 3.5. Since the old JIT was replaced with MCJIT it is no longer capable of adding new declarations to the module after a function from that module was executed. Some multi-module solution is possible but not implemented yet. 6 | 7 | LLVM bindings for MBase are included, see llvm-wrapper/* 8 | 9 | CLike is implemented in PFront, a domain-specific language for compiler construction. 10 | 11 | ## Motivational example 12 | 13 | C is a very low level language, without any built-in means for extensibility. C++ adds quite a few, but yet, it won't be easy to implement something like string interpolation syntax using only C++ language features. And C is a statically typed language, which makes the usual tricks barely possible here. Interpolated strings must embed typed expressions and act accordingly: 14 | 15 | ```C 16 | void test(int a, float b) { 17 | puts(£"A = $(a), B=$(b), A+B=$(a+b)\n"); 18 | } 19 | ``` 20 | 21 | CLike was designed to expore the design space of extensible syntax languages and a Lisp-style metaprogramming in a statically typed environment. See an example introducing this kind of syntax extension in `tests/syntax.c` 22 | 23 | It's easy to extend the language with the convenient high level features, like `foreach`, `reduce`, set comprehensions, and even semantically loaded things like lambda expressions, LINQ-style embedded queries, C++-style templates. No need to alter the core language compiler for any of these, it's all possible to implement as libraries on top of the existing language. 24 | 25 | More complicated things are also possible, like embedded, efficiently compiled regular expressions, type-safe binary protocol handlers, BNF parsers, and even embedded high level languages like Prolog, all compiled seamlessly alongside with the core CLike language, having an access to all the internal knowledge of the compiler, including types, lexical scope, global declarations, LLVM context, etc. 26 | 27 | ## What is it for? 28 | 29 | C is an ideal target for compiling higher level languages. It's got optimising compilers, it is low level enough to handle a very wide variety of semantics. But often a semantic gap between a high level language and C is huge, and translation is not that trivial and straightforward. CLike can bridge this gap in the very same way as MBase addresses the eDSL design in general - by introducing rich metaprogamming capabilities and comprehensive reflection. 30 | 31 | This way languages can be translated incrementally, via building new semantic features on top of an existing target language, instead of a classic compilation pipeline. Many interesting tricks are possible when growing languages this way, from mixing different languages together to allowing transparent fallbacks to the low level where it is needed. See the PFront language in MBase as an extreme example of this technique. 32 | 33 | ## Building 34 | 35 | [MBase 1.0.2 is required](https://github.com/combinatorylogic/mbase). Make sure MBase DLLs are installed into the GAC. 36 | 37 | The only supported environment currently is Linux on x86 or x86_64, with Mono > 3.0. 38 | 39 | Python 2.7, Clang (3.5) and cindex are required for building llvm-wrapper. Make sure `PYTHONPATH` points to `$CLANG_SOURCE/bindings/python`. If Python bindings are not available, a cached version will be used (currently provided for LLVM 3.5 and LLVM 3.6.0svn). 40 | 41 | pdflatex and graphviz are required for building documentation. 42 | 43 | Linux on ARM is not currently supported. If you want to try it anyway, make sure LLVM libraries are built with -fPIC. 44 | 45 | ## Clike code layout 46 | 47 | File | Description 48 | ---------------------- | ------------------------------------------------ 49 | clike.hl | Binds the core functionality together 50 | clike-standalone.hl | A version that does not need LLVM bindings 51 | clike-ast.hl | Internal CLike AST definitions 52 | clike-env.hl | Compiler environment support 53 | clike-types-utils.hl | 54 | clike-types.hl | Types propagation pass + typed macro expansion 55 | clike-compiler.hl | Function bodies compilation passes 56 | clike-expand.hl | Post-parsing expansion and a simple macro expander 57 | clike-compiler-top.hl | Top level expressions compiler and all compiler passes 58 |   | 59 | clike-parser.hl | A standard parser for CLike 60 | clike-utils.hl | Additional utilities, not used directly by a compiler 61 | clike-api.hl | .NET api to CLike functionality 62 |   | 63 | clike-lib.hl | To build CLikeCore.dll 64 | clike-llvm.hl | All the LLVM-depending functionality 65 |   | 66 | clike-cc.hl | A simple command-line compiler 67 | clike-cc-standalone.hl | A simple command-line compiler, no-LLVM version 68 | 69 | 70 | -------------------------------------------------------------------------------- /tests/syntax.c: -------------------------------------------------------------------------------- 1 | /* 2 | * A CLike demo showing its extensible syntax features. 3 | * See below: a reverse assignment syntax, infix function calls 4 | * and a string interpolation. 5 | * 6 | * How to build and run: 7 | * $ mono clikecc.exe /out syntax tests/syntax.c 8 | * $ lli syntax.o 9 | * 10 | */ 11 | 12 | 13 | 14 | // Defining a reverse assignement syntax ' expr =: lvalue ' 15 | ##syntax of pfclike in clcode, inner: ' [clrevset]:v ' 16 | + { clrevset := [clexpr]:r "=:" [cllvalue]:l";" => 17 | {mode=stmt} set($source(),l,r); } // Forming an AST directly 18 | { 19 | return v 20 | } 21 | 22 | // Defining an infix function syntax 23 | ##syntax of pfclike in classexpr, inner: ' [clbinexpr]:l "`" [clqident]:fn [clbinexpr]:r ' 24 | { 25 | return .clike-expr ` \fn\ (\l\, \r\) ` // using quasiquotation to form an AST 26 | } 27 | 28 | int32 printf(int8 *format, ...); 29 | int32 puts(int8 *str); 30 | 31 | int32 add2(int32 x, int32 y) { 32 | return x*x + y*y; 33 | } 34 | 35 | void demo0() { 36 | int32 a, b, c; 37 | 38 | // reversed assignement syntax 39 | 2+2 =: a; 40 | a*a =: b; 41 | b-a =: c; 42 | printf("%d,%d,%d\n", a, b, c); 43 | 44 | // Infix function call demo 45 | int32 d = (a `add2 b) `add2 c; 46 | printf("%d\n", d); 47 | } 48 | 49 | // Defining a string interpolation syntax 50 | ##syntax of pfclike in clexpr, inner: ' "£" [DQUOTE] [stringinterp]:v [DQUOTE] ' 51 | + { 52 | @@DQUOTE := 34; 53 | @@escapebegin := "$("; 54 | @@text := (![DQUOTE] ((![escapebegin] .)/("\\$")))+; 55 | @tktext := [text]; 56 | escape := [escapebegin] [clexpr]:e ")" => e; 57 | stringinterp := eslist<[stringiatom]>:es => es; 58 | stringiatom := { [escape]:e => escape(e) } 59 | / { [tktext]:t => text($val(t)) } 60 | ; 61 | } 62 | { 63 | // 1. Assess minimum string length 64 | minlen = foldl(fun(l, s) { l + length(%string->list(s)) }, 0, 65 | map v do match v with text(t) -> t | else -> "DUMMY"); 66 | // Make an integer constant 67 | tsminlen = 'const'('integer'('i32', minlen)); 68 | // 2. Build a sequence of collect_str calls 69 | collect = 'begin'( 70 | @map v do 71 | match v with 72 | text(t) -> {ts = 'const'('string'(t)); 73 | len = length(%string->list(t)); 74 | tslen = 'const'('integer'('i32', len)); 75 | .clike-code `collect_const_str(&builder, \ts\, \tslen\ );`} 76 | | escape(e) -> 77 | 'expr'('typedmacro'('tostring','expr'(e)))); 78 | // 3. Create an inblock expression 79 | return .clike-expr ` 80 | inblock { 81 | strbuilder builder; 82 | makestringbuilder(&builder, \tsminlen\ ); 83 | ::code \collect\; 84 | ( getstringfrombuilder(&builder) ); // make sure this call is an expression 85 | } 86 | `; 87 | } 88 | 89 | // Now we have to define 'tostring' macro used above 90 | 91 | clike macro tostring { 92 | syntax : ' "@" tostring "(" [clexpr]:e ")" '; 93 | typing : 'void'(); // side effect 94 | expand as: { 95 | match typeof_e with 96 | 'ptr'('integer'('i8')) -> // already a string 97 | .clike-expr `collect_str(&builder, \e\)` 98 | | 'integer'(itype) -> .clike-expr ` itoa_i64 ( &builder, \e\ ) ` 99 | | 'real'(rtype) -> .clike-expr ` ftoa_double ( &builder, \e\ ) ` 100 | | 'struct'(nm, @elts) -> symbols(strct) { 101 | fillstruct = 'begin'( 102 | @map append [fld;ftp] in elts do 103 | [ 104 | {fldnm = 'const'('string'(%S<<(fld,"="))); .clike-code `collect_str(&builder, \fldnm\ );`}; 105 | 'expr'('typedmacro'('tostring','expr'('getelt'('deref'('var'(strct)), fld)))); 106 | .clike-code `collect_str(&builder, ";");` 107 | ] 108 | ); 109 | strnm = 'const'('string'(if(nm) %S<<("@[", car(nm), " ") else "@[... ")); 110 | clike_expand_core_expr( 111 | .clike-expr `inblock {collect_str(&builder, \strnm\ ); 112 | var \strct\ = &(::expr \e\) ; 113 | ::code \fillstruct\; 114 | collect_str(&builder, "]"); 115 | (0);}`) 116 | } 117 | // We can do a lot of interesting things here: implement pretty printers 118 | // for recursive structures and arrays, implement an extensible system of 119 | // type-dependent printers, etc., but for the sake of simplicity we'll 120 | // stick to simple types here. 121 | | else -> {println(typeof_e); .clike-expr `collect_str(&builder, "")`} 122 | } 123 | } 124 | 125 | // The stuff below must be in the library 126 | typedef struct _strbuilder { 127 | uint32 pos; 128 | uint32 size; 129 | int8 *ptr; 130 | } strbuilder; 131 | 132 | void *malloc(uint64 size); 133 | void *realloc(void *ptr, uint64 size); 134 | void *memcpy(void *dest, void *src, uint64 n); 135 | 136 | void advance(strbuilder *builder, int32 len) 137 | { 138 | if (builder->pos + len >= builder->size) { 139 | builder->size *= 2; 140 | builder->ptr = realloc(builder->ptr, builder->size); 141 | } 142 | } 143 | 144 | void collect_const_str(void *builder, int8 *str, int32 len) 145 | { 146 | strbuilder *b = (strbuilder*) builder; 147 | advance(b, len); 148 | memcpy(b->ptr + b->pos, str, len); 149 | b->pos += len; 150 | } 151 | void collect_str(void *builder, int8 *str) 152 | { 153 | strbuilder *b = (strbuilder*) builder; 154 | uint32 pos = b->pos; uint32 size = b->size; 155 | uint32 i; 156 | for (i = 0; str[i]; ++i) { 157 | if (pos+i >= size) {advance(b,i); size = b->size;} 158 | b->ptr[pos+i] = str[i]; 159 | } 160 | b->pos += i; 161 | } 162 | 163 | int32 snprintf(int8 *str, uint64 size, int8 *format, ...); 164 | 165 | // Could have been more optimal 166 | void itoa_i64(void *builder, int64 v) 167 | { 168 | int32 temp[192]; 169 | snprintf(temp, 191, "%ld", v); 170 | collect_str(builder, temp); 171 | } 172 | void ftoa_double(void *builder, double v) 173 | { 174 | int32 temp[192]; 175 | snprintf(temp, 191, "%g", v); 176 | collect_str(builder, temp); 177 | } 178 | 179 | void makestringbuilder(strbuilder *v, int32 minlen) 180 | { 181 | v->pos = 0; 182 | v->size = minlen; 183 | v->ptr = malloc(minlen+1); 184 | } 185 | int8* getstringfrombuilder(void *builder) 186 | { 187 | strbuilder *b = (strbuilder*) builder; 188 | b->ptr[b->pos] = 0; // terminate this string 189 | return b->ptr; 190 | } 191 | ////////////////////////////////////////// 192 | 193 | 194 | void demo1() 195 | { 196 | int32 a = 200; 197 | int16 b = 40; 198 | int8* gs = "String"; 199 | 200 | // String interpolation demo 201 | puts(£"A = $(a), B = $(b), A+B=$(a+b), 5/3 = $(5.0/3.0), GS=$(gs)"); 202 | 203 | 204 | struct _abc { 205 | int32 f1; 206 | int8 f2; 207 | int8* s; 208 | struct { 209 | int32 x; 210 | } inner; 211 | } test; 212 | test.f1 = 1; 213 | test.f2 = 2; 214 | test.s = "TEST"; 215 | test.inner.x = 10; 216 | puts(£"Struct test: $(test)"); 217 | } 218 | 219 | 220 | int32 main() 221 | { 222 | demo0(); 223 | demo1(); 224 | return 0; 225 | } -------------------------------------------------------------------------------- /tests/syntax.ref: -------------------------------------------------------------------------------- 1 | 4,16,12 2 | 74128 3 | A = 200, B = 40, A+B=240, 5/3 = 1.66667, GS=String 4 | Struct test: @[_abc f1=1;f2=2;s=TEST;inner=@[... x=10;];] 5 | -------------------------------------------------------------------------------- /tests/templates.c: -------------------------------------------------------------------------------- 1 | #include "../tools/templates.h" 2 | 3 | typedef int32 int; 4 | 5 | template inline A f(A i) { 6 | return i * (A)N; 7 | } 8 | 9 | template void fillArray() { 10 | int a[N]; 11 | for (int i = 0; i < N; i++) a[i] = 0; 12 | } 13 | 14 | template void testfun(A *i, A x) { 15 | *i = x; 16 | } 17 | 18 | // TODO: 19 | /* 20 | template B testfun1(A *i) { 21 | return i->x; 22 | } 23 | */ 24 | 25 | int test(int a) 26 | { 27 | int x; 28 | testfun<>(&x, 2); 29 | fillArray<10>(); 30 | fillArray<20>(); 31 | return f<2, ::type int>(2*a) + 32 | f<2>(a) + f<4>(2); 33 | } 34 | 35 | int32 printf(int8 *format, ...); 36 | 37 | int main() 38 | { 39 | printf("D=%d\n", test(2)); 40 | return -1; 41 | } -------------------------------------------------------------------------------- /tests/tests.c: -------------------------------------------------------------------------------- 1 | /* A sort of a large testsuite */ 2 | /* All the output goes to stdout */ 3 | 4 | 5 | typedef int32 int; 6 | typedef int8 char; 7 | 8 | void * malloc(int32); 9 | void free(void *); 10 | 11 | int puts(char[]); 12 | void fflush(int); 13 | 14 | int printf(int8 *format, ...); 15 | 16 | ##define tests = collector(add,get) {add:get} 17 | 18 | ##syntax of pfclike in cltop, start: ' "$" test [clqident]:nm "{" eslist<[clcode]>:es "}" ' 19 | { 20 | name = %Sm<<("testfun_",nm); 21 | (car(tests))(name); 22 | ss = 'const'('string'(%S<<("\nTest: ",nm,"\n"))); 23 | intr = .clike-expr `printf( \ss\ )`; 24 | flush = .clike-expr `fflush(0)`; 25 | ess = 'begin'(@es); 26 | return .clike 27 | `void \name\() { ::expr \intr\; ::code \ess\; ::expr \flush\;}`; 28 | } 29 | 30 | ##syntax of pfclike in cltop, start: ' "$" disable test [clqident]:nm "{" eslist<[clcode]>:es "}" ' 31 | { 32 | name = %Sm<<("testfun_",nm); 33 | ss = 'const'('string'(%S<<("\nTest: ",nm,"\n"))); 34 | intr = .clike-expr `printf( \ss\ )`; 35 | flush = .clike-expr `fflush(0)`; 36 | ess = 'begin'(@es); 37 | return .clike 38 | `void \name\() { ::expr \intr\; ::code \ess\; ::expr \flush\;}`; 39 | } 40 | 41 | ##syntax of pfclike in clcode, start: ' "$" allthetests ' 42 | { 43 | rt = (cdr(tests))(); 44 | return 'begin'(@map rt do 'expr'('call'([],rt))); 45 | } 46 | 47 | 48 | clike macro TypeOf { 49 | syntax : '"@" TypeOf "(" [clexpr]:e ")"'; 50 | typing : 'ptr'('integer'('i8')); 51 | expand as: { 'const'('string'(%S<<(typeof_e))) } 52 | } 53 | 54 | ///////////////////////////////////////////// 55 | 56 | $test ts_1 57 | { 58 | int a = 2; 59 | int b = 2; 60 | printf("4=%d\n",a+b); 61 | } 62 | 63 | $test ts_2 64 | { 65 | int a = 2; 66 | int b = a/2+1; 67 | printf("4=%d\n",a*b); 68 | } 69 | 70 | $test ts_3 71 | { 72 | int c = 1; 73 | for(int i = 1; i<= 5; i++) c*=i; 74 | printf("5!=%d\n", c); 75 | } 76 | 77 | $test ts_4 78 | { 79 | int abc[10]; 80 | for(int i = 0; i<10; i++) abc[i] = i; 81 | int c = 0; 82 | for(int j = 0; j<10; j++) c+=abc[j]; 83 | printf("sum[0..9] = %d\n",c); 84 | } 85 | 86 | $test ts_5 87 | { 88 | int abc[11]; 89 | for(int i = 0; i<10; i++) abc[i] = i+15; 90 | int *cde; 91 | cde = &(abc[0]); 92 | int c = 0; 93 | printf("(abc==cde)=%d\n",((int*)abc)==cde); 94 | for(int j = 0; j<10; j++) c+= (*(cde+j)); 95 | printf("sum[A..B] = %d\n",c); 96 | } 97 | 98 | $test ts_6 99 | { 100 | char c; 101 | int i = 32; 102 | c = i; 103 | printf("Space is '%c'\n",c); 104 | } 105 | 106 | $test ts_7 107 | { 108 | int cnt = 0; 109 | for(int i = 0;i<10; i++) 110 | for(int j = 0; j<10; j++) cnt++; 111 | printf("100=%d\n",cnt); 112 | } 113 | 114 | $test ts_8 115 | { 116 | int abc = 1; 117 | int cde = 2; 118 | printf("1=%d, 3=%d\n",abc++,++cde); 119 | printf("2=%d\n", abc); 120 | } 121 | 122 | $test ts_9 123 | { 124 | int abc = 1; 125 | abc*=2; 126 | abc+=2; 127 | abc*=3; 128 | abc/=2; 129 | printf("6=%d\n", abc); 130 | } 131 | 132 | int strlen(char s[]) 133 | { 134 | int l; 135 | for(l=0;s[l];l++); 136 | return l; 137 | } 138 | 139 | void reverse(char s[]) 140 | { 141 | int i, j; 142 | char c; 143 | 144 | for (i = 0, j = strlen(s)-1; i1) return n*rfct(n-1); else return 1; 272 | } 273 | } 274 | 275 | printf("rec 5!=%d\n", rfct(5)); 276 | } 277 | 278 | $test ts_22 279 | { 280 | lift { int glob_counter; } 281 | glob_counter = 500; 282 | glob_counter++; 283 | 284 | printf("501=%d\n", glob_counter); 285 | } 286 | 287 | $test ts_23 288 | { 289 | glob_counter++; 290 | 291 | printf("502=%d\n", glob_counter); 292 | } 293 | 294 | $test ts_24 295 | { 296 | lift { int __fun_1() { 297 | 298 | return inblock { lift { int __fun_2(int x) 299 | { 300 | return x*2; 301 | }} (1); }; 302 | } 303 | } 304 | printf("8=%d\n", __fun_2(__fun_2(2))); 305 | } 306 | 307 | $test ts_25 308 | { 309 | int abc = 10; 310 | if(abc<5) goto L1; 311 | if(abc>5) goto L2; 312 | goto L3; 313 | 314 | L1: 315 | printf("L1\n"); goto E; 316 | L2: 317 | printf("L2\n"); goto E; 318 | L3: 319 | printf("L3\n"); goto E; 320 | 321 | E: 322 | printf(" ...\n"); 323 | } 324 | 325 | 326 | $test ts_26 327 | { 328 | char *str = "String String String"; 329 | int *istr = (int*)malloc(sizeof(int)*strlen(str)); 330 | for(int i = 0; str[i]; i++) istr[i] = str[i]; istr[i] = 0; 331 | for(int j = 0; istr[j]; j++) printf("%c",(char)istr[j]); 332 | printf("\n"); 333 | } 334 | 335 | typedef struct _stest_27 { 336 | int a; 337 | int b[5]; 338 | } stest_27; 339 | 340 | typedef struct _stest_27_1 { 341 | int a; 342 | struct _stest_27 b; 343 | } stest_27_1; 344 | 345 | void test27_print(struct _stest_27_1 *a) 346 | { 347 | printf("a.a=%d, a.b.a = %d, a.b.b[3] = %d\n", 348 | a->a, a->b.a, a->b.b[3]); 349 | } 350 | 351 | $test ts_27 352 | { 353 | struct _stest_27_1 a; 354 | a.a = 1; 355 | a.b.a = 2; 356 | a.b.b[3] = 3; 357 | test27_print(&a); 358 | printf("TypeOf(a.b)=%s\n",@TypeOf(a.b)); 359 | } 360 | 361 | $test ts_28 362 | { 363 | struct { char x; int y; } a; 364 | a.x = 99; 365 | a.y = 20; 366 | printf("1980 = %d, a.x = %d\n", a.x * a.y,(int)a.x); 367 | } 368 | 369 | $test ts_29 370 | { 371 | double x = 2.5 * 3.6; 372 | printf("2.5*3.6 = %f\n", x); 373 | } 374 | 375 | $test ts_30 376 | { 377 | printf("c=%d, i=%d, l=%d, f=%d, d=%d\n",(int)sizeof(char),(int)sizeof(int), (int)sizeof(int64), (int)sizeof(float), 378 | (int)sizeof(double)); 379 | } 380 | 381 | $test ts_31 382 | { 383 | struct _xx { 384 | int x[5]; float y[10]; struct _xx *next; 385 | } a; 386 | 387 | struct _xx b; 388 | 389 | printf("t1=%s, t2=%s, t3=%s, t4=%s, t5=%s, t6=%s\n", @TypeOf(sizeof(int)), @TypeOf(2*2), @TypeOf(1.5+1), @TypeOf("abcd"), @TypeOf(a), @TypeOf(b)); 390 | } 391 | 392 | // Unaligned access 393 | $test ts_32 394 | { 395 | char *abcd = "abcd"; 396 | uint32 a = * ((uint32*)abcd); 397 | 398 | char *abcd1 = (char*)malloc(7); 399 | abcd1[0] = 'X'; 400 | *((uint32*)(abcd1+1)) = a; // Definitely unaligned 401 | abcd1[5] = 0; 402 | printf("abcd=%s\n", abcd1); 403 | } 404 | 405 | 406 | typedef struct _t33s { 407 | int a[5]; 408 | int b[5]; 409 | float c; 410 | } t33s; 411 | 412 | t33s test_33_helper(int x, int y, int z) 413 | { 414 | t33s s; 415 | s.a[4] = x; 416 | s.b[1] = y; 417 | s.c = (float)z; 418 | printf("A: 1,2,3 : %d,%d,%d\n",s.a[4],s.b[1],(int)s.c); 419 | return s; 420 | } 421 | 422 | $test ts_33 423 | { 424 | printf("Size=%d\n", (int)sizeof(t33s)); 425 | 426 | 427 | t33s s = test_33_helper(1,2,3); 428 | printf("B: 1,2,3 : %d,%d,%d\n",s.a[4],s.b[1],(int)s.c); 429 | } 430 | 431 | $test ts_34 432 | { 433 | lift { typedef struct _sss { int x; int y; int z; } sss; }; 434 | sss *X; 435 | sss Y; 436 | 437 | Y.x = 1; Y.y = 2; Y.z = 3; 438 | X = &Y; 439 | printf("%d,%d,%d\n", X->x, X->y, X->z); 440 | } 441 | 442 | $test ts_35 443 | { 444 | var x = 2.5*10; 445 | var y = "What?"; 446 | 447 | printf("==%s : %s\n", @TypeOf(x), @TypeOf(y)); 448 | } 449 | 450 | $test ts_36 451 | { 452 | int8 a = 1; 453 | int16 b = 2; 454 | uint16 c = 3; 455 | uint32 d = 4; 456 | int32 e = 5; 457 | int64 f = 10; 458 | var x = a+b+c+d+e+f+e+d+c+b+a; 459 | printf("Typeof(x) = %s\n", @TypeOf(x)); 460 | } 461 | 462 | $test ts_37 463 | { 464 | int c = 0; 465 | for(int i = 0; i<10; i++) 466 | for(int j = 10; j; j--) 467 | for(int k = 0; k<20; k+=2) 468 | c++; 469 | printf("1000=%d\n",c); 470 | } 471 | 472 | $test ts_38 473 | { 474 | int a = 10; 475 | void* b = (void *) &a; 476 | int *c = (int *) b; 477 | printf("10=%d\n", *c); 478 | } 479 | 480 | $test ts_39 481 | { 482 | printf("%d,%d,%d,%d\n", 1>=1, 1>=0, 2<3,2<=2); 483 | printf("%d,%d,%d,%d\n", 1.1>=1.1, 1.0>=0, 2.5<3,2.1<=2); 484 | } 485 | 486 | $test ts_40 487 | { 488 | int a = 25,b=0; 489 | for(;a>0;a--) b++; 490 | for(;a<25;a++) b++; 491 | printf("b=%d [50]\n", b); 492 | } 493 | 494 | $test ts_41 495 | { 496 | int a = 1; 497 | var b = a<<4-1; 498 | printf("15=%d\n", b); 499 | } 500 | 501 | $test ts_42 502 | { 503 | lift { 504 | uint32 Ack(uint32 x, uint32 y){return (x>0)?Ack(x-1,(y>0)?Ack(x,y-1):1):y+1;} 505 | } 506 | printf("(2,3)=%d\n(3,10)=%d\n",Ack(2,3),Ack(3,10)); 507 | } 508 | 509 | $test ts_43 510 | { 511 | lift { 512 | void ts_43_ifun(int c, int r) { 513 | int x = 0; 514 | switch(c) { 515 | case 0: x = 1; break; 516 | case 1: x = 1; break; 517 | case 2: 518 | case 3: 519 | case 4: x = 2; break; 520 | default: x = 3; 521 | } 522 | printf("X=%d (%d)\n", x,r); 523 | } 524 | } 525 | ts_43_ifun(3,2); 526 | ts_43_ifun(4,2); 527 | ts_43_ifun(1,1); 528 | ts_43_ifun(11,3); 529 | ts_43_ifun(-1,3); 530 | } 531 | 532 | $test ts_44 533 | { 534 | int i = 0,j=0; 535 | for(;i<100;i++) { 536 | for(;;) { 537 | for(;;) { 538 | for(;;) { 539 | for(;;) { 540 | for(;;) { 541 | j++; 542 | goto exit; 543 | } 544 | } 545 | } 546 | } 547 | } 548 | exit: 549 | } 550 | printf("100=%d\n",j); 551 | } 552 | 553 | 554 | $test ts_45 555 | { 556 | int i = 0,j=0,k; 557 | for(;i<100;i++) { 558 | for(;;) { 559 | while(1) { 560 | for(;;) { 561 | for(;;) { 562 | for(;;) { 563 | for(;;) { 564 | for(;;) { 565 | for(;;) { 566 | for(;;) { 567 | for(;;) { 568 | for(;;) { 569 | for(;;) { 570 | do { 571 | for(;;) { 572 | for(;;) { 573 | for(;;) { 574 | for(;;) { 575 | for(;;) { 576 | for(;;) { 577 | for(;;) { 578 | for(;;) { 579 | for(;;) { 580 | for(;;) { 581 | for(;;) { 582 | for(;;) { 583 | for(;;) { 584 | for(;;) { 585 | for(k=0;k<10;k++) { 586 | j++; 587 | } 588 | goto exit; 589 | }}}}}}}}}}}}}}} while(1) }}}}}}}}}} 590 | } 591 | 592 | } 593 | exit: 594 | } 595 | printf("1000=%d\n",j); 596 | } 597 | 598 | /* 599 | $disable test ts_46 600 | { 601 | lift { 602 | void duff(int *ato, int *afrom, int count) 603 | { 604 | int *to = ato; int *from = afrom; 605 | int n=(count+7)/8; 606 | switch(count%8){ 607 | case 0: doentry: *(to++) = *(from++); 608 | case 7: *(to++) = *(from++); 609 | case 6: *(to++) = *(from++); 610 | case 5: *(to++) = *(from++); 611 | case 4: *(to++) = *(from++); 612 | case 3: *(to++) = *(from++); 613 | case 2: *(to++) = *(from++); 614 | case 1: *(to++) = *(from++); 615 | if(--n>0) goto doentry; 616 | } 617 | } 618 | } 619 | int *test = (int*)malloc(10002); 620 | int *test1 = (int*)malloc(10002); 621 | int i; 622 | int c = 1; 623 | for(i = 0; i < 10000; i++) { 624 | test[i] = i*2+i/3+i/4+i%8192; 625 | } 626 | duff(test1, test, 10000); 627 | for(i = 0; i < 10000; i++) { 628 | if(test[i]!=test1[i]) { c = 0; 629 | printf("Deduff[%d,%d,%d]\n",i,test[i],test1[i]); 630 | break; } 631 | } 632 | printf("Duff? [%d]\n", c); 633 | } 634 | */ 635 | 636 | //////// Recursive structures test 637 | typedef struct _list { 638 | int elt; 639 | struct _list *next; 640 | } list; 641 | 642 | list *mklist(int n, list * next) 643 | { 644 | list * l; 645 | l = (list*)malloc(sizeof(list)); 646 | l->elt = n; 647 | l->next = next; 648 | return l; 649 | } 650 | 651 | 652 | list *addtolist(list *l, int n) 653 | { 654 | list* l1 = mklist(n,NULL); 655 | l->next = l1; 656 | return l1; 657 | } 658 | 659 | 660 | void freelist(list* l) { 661 | list* tmp=l->next; 662 | list* c = l; 663 | while(tmp!=NULL) { 664 | free(c);c=tmp; tmp=c->next; 665 | } 666 | } 667 | 668 | void printlist(list *lst) 669 | { 670 | if(lst==NULL) return; 671 | 672 | printf("%d ",lst->elt); 673 | printlist(lst->next); 674 | } 675 | 676 | 677 | ##syntax of pfclike in clexpr, inner: '"$list" "{" ecslist<[clexpr],";">:es "}"' 678 | { 679 | do loop(e = es) 680 | match e with 681 | hd:tl -> {nxt = loop(tl); .clike-expr ` mklist( \hd\ , \nxt\ ) `} 682 | | else -> .clike-expr ` NULL ` 683 | } 684 | 685 | 686 | ##syntax of pfclike in clcode, start: 687 | 'foreach "(" [clqident]:id0 in [clexpr]:e ")" [clcode]:body0 ' 688 | { 689 | symbols(s1,id) { 690 | s1v='var'(s1); 691 | body = clike_renvar_code(body0, id0, id); 692 | .clike-code `{var \s1\ = ::expr \e\; 693 | do { 694 | var \id\ = \s1v\->elt; 695 | \body\; 696 | ::lvalue \s1v\ = \s1v\->next; 697 | } while(\s1v\!=NULL)} ` 698 | }} 699 | 700 | 701 | int listsum(list* l) 702 | { 703 | int s = 0; 704 | foreach(c in l) s+=c; 705 | return s; 706 | } 707 | 708 | $test ts_47 709 | { 710 | int x = 2; 711 | var l = $list {1;x;3;4;5;10;9;8;7;x*2}; 712 | printlist(l); printf("\n"); 713 | printf("Sum=%d\n", listsum(l)); 714 | freelist(l); 715 | } 716 | 717 | int ord(int x) 718 | { 719 | printf("[%d]", x); 720 | return x; 721 | } 722 | 723 | $test ts_47x 724 | { 725 | var l = $list {ord(1);ord(2);ord(3);ord(4)}; 726 | printf("\n"); 727 | printlist(l); 728 | printf("\n"); 729 | freelist(l); 730 | } 731 | 732 | /* 733 | $test ts_48 734 | { 735 | int x[3] = [1,2,3]; 736 | 737 | printf("5=%d\n", x[2]+x[1]); 738 | } 739 | */ 740 | 741 | int globarray[100]; 742 | 743 | $test ts_globarray 744 | { 745 | globarray[1] = 1; 746 | globarray[20] = 20; 747 | printf("21=%d\n", globarray[1] + globarray[20]); 748 | } 749 | 750 | ////////////////////////////////////////////// 751 | 752 | void main() 753 | { 754 | $allthetests 755 | } 756 | 757 | int testmain(int x) 758 | { 759 | main(); 760 | return 0; 761 | } 762 | 763 | ##{ 764 | tfun = clike_get_ptr("testmain"); 765 | #(_InvokeFunc1 tfun 0); 766 | } 767 | 768 | -------------------------------------------------------------------------------- /tests/tests.ref: -------------------------------------------------------------------------------- 1 | Compiling: (c "tests/tests.c") 2 | 3 | Test: ts_1 4 | 4=4 5 | 6 | Test: ts_2 7 | 4=4 8 | 9 | Test: ts_3 10 | 5!=120 11 | 12 | Test: ts_4 13 | sum[0..9] = 45 14 | 15 | Test: ts_5 16 | (abc==cde)=1 17 | sum[A..B] = 195 18 | 19 | Test: ts_6 20 | Space is ' ' 21 | 22 | Test: ts_7 23 | 100=100 24 | 25 | Test: ts_8 26 | 1=1, 3=3 27 | 2=2 28 | 29 | Test: ts_9 30 | 6=6 31 | 32 | Test: ts_10 33 | Rev: 'esaelp gnirts siht esrever' 34 | 35 | Test: ts_11 36 | 10=10 37 | 38 | Test: ts_12 39 | Str='WowWowWow' 40 | 41 | Test: ts_13 42 | 8=8 43 | 44 | Test: ts_14 45 | s = 's','t' 46 | 47 | Test: ts_15 48 | 'teXt' 49 | 50 | Test: ts_16 51 | Space=' ' (32) 52 | 53 | Test: ts_17 54 | 6=6 55 | 56 | Test: ts_18 57 | 7=7 58 | 59 | Test: ts_19 60 | C = 64 61 | 62 | Test: ts_20 63 | [133][26][0][0] 64 | [133][26][0][0] 65 | 66 | Test: ts_21 67 | rec 5!=120 68 | 69 | Test: ts_22 70 | 501=501 71 | 72 | Test: ts_23 73 | 502=502 74 | 75 | Test: ts_24 76 | 8=8 77 | 78 | Test: ts_25 79 | L2 80 | ... 81 | 82 | Test: ts_26 83 | String String String 84 | 85 | Test: ts_27 86 | a.a=1, a.b.a = 2, a.b.b[3] = 3 87 | TypeOf(a.b)=(struct (_stest_27) (a (integer i32)) (b (array (integer i32) (5)))) 88 | 89 | Test: ts_28 90 | 1980 = 1980, a.x = 99 91 | 92 | Test: ts_29 93 | 2.5*3.6 = 9.000000 94 | 95 | Test: ts_30 96 | c=1, i=4, l=8, f=4, d=8 97 | 98 | Test: ts_31 99 | t1=(integer i64), t2=(integer i32), t3=(real double), t4=(ptr (integer i8)), t5=(struct (_xx) (x (array (integer i32) (5))) (y (array (real float) (10))) (next (ptr (structref _xx)))), t6=(struct (_xx) (x (array (integer i32) (5))) (y (array (real float) (10))) (next (ptr (structref _xx)))) 100 | 101 | Test: ts_32 102 | abcd=Xabcd 103 | 104 | Test: ts_33 105 | Size=44 106 | A: 1,2,3 : 1,2,3 107 | B: 1,2,3 : 1,2,3 108 | 109 | Test: ts_34 110 | 1,2,3 111 | 112 | Test: ts_35 113 | ==(real double) : (ptr (integer i8)) 114 | 115 | Test: ts_36 116 | Typeof(x) = (integer i64) 117 | 118 | Test: ts_37 119 | 1000=1000 120 | 121 | Test: ts_38 122 | 10=10 123 | 124 | Test: ts_39 125 | 1,1,1,1 126 | 1,1,1,0 127 | 128 | Test: ts_40 129 | b=50 [50] 130 | 131 | Test: ts_41 132 | 15=15 133 | 134 | Test: ts_42 135 | (2,3)=9 136 | (3,10)=8189 137 | 138 | Test: ts_43 139 | X=2 (2) 140 | X=2 (2) 141 | X=1 (1) 142 | X=3 (3) 143 | X=3 (3) 144 | 145 | Test: ts_44 146 | 100=100 147 | 148 | Test: ts_45 149 | 1000=1000 150 | 151 | Test: ts_47 152 | 1 2 3 4 5 10 9 8 7 4 153 | Sum=53 154 | 155 | Test: ts_47x 156 | [1][2][3][4] 157 | 1 2 3 4 158 | 159 | Test: ts_globarray 160 | 21=21 161 | Done. 162 | -------------------------------------------------------------------------------- /tests/typeof.c: -------------------------------------------------------------------------------- 1 | #include "../tools/decltype.h" 2 | 3 | typedef struct _teststr { 4 | int32 x; 5 | } teststr; 6 | 7 | int32 test(teststr *z) { 8 | 9 | typeof(z->x) x = z*z; 10 | typeof(x) y = x+x; 11 | return y; 12 | } 13 | 14 | int32 printf(int8 *format, ...); 15 | 16 | int32 main() 17 | { 18 | teststr a; 19 | a.x = 2; 20 | printf("D=%d\n", &a); 21 | return -1; 22 | } 23 | 24 | 25 | -------------------------------------------------------------------------------- /tools/decltype.h: -------------------------------------------------------------------------------- 1 | 2 | ##syntax of pfclike in cltype, start: ' typeof "(" [clexpr]:e ")" ' 3 | { 4 | return 'typedmacro'('typeof_macro', 'expr'(e)) 5 | } 6 | 7 | clike macro typeof_macro { 8 | syntax : ' "@" typeof_macro "(" [clexpr]:e ")" '; 9 | typing : 'void'(); // discarded 10 | expand as: { return typeof_e }} 11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /tools/templates.h: -------------------------------------------------------------------------------- 1 | // A very simple template-like system, supporting only template functions (no types) 2 | // 3 | // E.g.: 4 | // 5 | // template A f(A i) { 6 | // return i * (A)N; 7 | // } 8 | // 9 | // Use it as: 10 | // f<2>(2.0) 11 | // 12 | 13 | ##include "../clike/clike-ast.hl" 14 | 15 | ##syntax of pfclike in cltop, start: 16 | ' [cltemplate]:t ' 17 | + { 18 | cltemplate := template "<" cslist<[cltemplatearg],",">:args ">" 19 | [clfuncannotations]:as 20 | [clfuncsignature]:sig "{" eslist<[clcode]>:es "}" => 21 | funtemplate(args, cfunc($source(), @sig,begin(@es),@as)); 22 | // TODO: ellipsis 23 | cltemplatearg := { typename [qident]:id => typename(id) } 24 | / { [cltypebase]:t [qident]:id => typed(id, t) } 25 | ; 26 | } 27 | { 28 | return 'pfront'('expr'('lisp'('clike_register_template'('quote'(t))))) 29 | } 30 | 31 | ##syntax of pfclike in clexpr, inner: 32 | ' "::template"? [clqident]:fn "<" ecslist<[cltemplateapparg],",">:targs ">" 33 | "(" ecslist<[clexpr0],",">:args ")"' 34 | + { 35 | cltemplateapparg := { "::type" [cltype]:t => type(t) } 36 | / { "::expr" [clexpr]:e => expr(e) } 37 | / { [clatomexpr]:e => expr(e) } 38 | / { [cltype]:t => type(t) } 39 | ; } 40 | { return 'typedmacro'('expand_template_app', 41 | 'verb'(fn),@targs, 'verb'('*COMMA*'),@map a in args 42 | do 'expr'(a)) 43 | } 44 | 45 | ##define clike_template_defns = mkhash() 46 | ##define clike_template_insts = mkhash() 47 | 48 | ##function clike_fun_to_decl(f) 49 | visit:clike(lltoplev: f) { 50 | once lltoplev { 51 | cfunc -> 'efunc'(LOC, cc, ret, name, va, args,@annotations) 52 | | efunc -> node 53 | | else -> ccerror('IMPOSSIBLE'())}} 54 | 55 | ##function clike_register_template(t) { 56 | match t with 57 | funtemplate(targs, fdef) -> { 58 | decl = clike_expand_core(clike_fun_to_decl(fdef)); 59 | = visit:clike(lltoplev: decl) { 60 | once llfuncarg: tp; 61 | deep lltoplev { 62 | efunc -> name:args 63 | | else -> ccerror('IMPOSSIBLE'())}}; 64 | ohashput(clike_template_defns, nm, [targs;fargs;fdef])}} 65 | 66 | 67 | ##function clike_get_template_defn(nm) { 68 | chk = ohashget(clike_template_defns, nm); 69 | if (chk) return chk else ccerror('UNDEFINED-TEMPLATE-FUNCTION'(nm)) 70 | } 71 | 72 | ##function clike_template_instantiate(env, tbody, bindtypes, bindexprs) { 73 | visit:clike(lltoplev: tbody) { 74 | deep lltype { 75 | alias -> aif(chk = ohashget(bindtypes, x)) { 76 | return chk 77 | } else node 78 | | else -> node}; 79 | deep llexpr { 80 | var -> aif(chk = ohashget(bindexprs, nm)) { 81 | return chk 82 | } else node 83 | | else -> node}}} 84 | 85 | ## 86 | %"A modified version of clike_type_iso" 87 | function clike_type_iso_match(env, a, b) 88 | do loop(t1=a, t2=b) { 89 | match t1:t2 with 90 | 'alias'(nm):x -> 91 | aif (chk = ohashget(env, nm)) { 92 | if (chk === '*unbound*') {ohashput(env, nm, x); return true} 93 | else []} 94 | | 'integer'(t1):'integer'(t2) -> %eqv?(t1,t2) 95 | | 'ptr'(a):'ptr'(b) -> loop(a,b) 96 | | 'ptr'(a):'array'(b,@r1) -> loop(a,b) 97 | | 'array'(a,@r):'ptr'(b) -> loop(a,b) 98 | | 'array'(a,@r):'array'(b,@r1) -> and(loop(a,b),iso(r,r1)) 99 | | x:y -> { 100 | s1 = clike_isstruct(x);s2=clike_isstruct(y); 101 | if(and(s1,s2)) %eqv?(s1,s2) else iso(x,y) 102 | }} 103 | 104 | ##parser templateargnm (pfront) { 105 | templateargnm := { "template_arg_" [ident]:i => i } 106 | / { . => $nil() } 107 | ;} 108 | 109 | ## 110 | function clike_template_unitype(env, bindenv, tp) 111 | { 112 | // 1. Dirty hack: replace aliases with structrefs 113 | tp0 = visit:clike(lltype:tp) { 114 | deep lltype { 115 | alias -> aif (chk = ohashget(bindenv, x)) { 116 | if (chk === '*unbound*') 'structref'(%Sm<<("template_arg_",x)) else chk 117 | } else node 118 | | else -> node}}; 119 | // 2. Normalise 120 | tp1 = clike_env_unitype(env, tp0); 121 | // 3. Return aliases 122 | tp2 = visit:clike(lltype:tp1) { 123 | deep lltype { 124 | structref -> aif (nnm = parse %S<<(nm) as templateargnm) { 125 | 'alias'(nnm) 126 | } else node 127 | | else node}}; 128 | return tp2} 129 | 130 | ## 131 | %"Execute the typing phase of macro expansion; 132 | Returns signature and the template function return type 133 | and requests argument type checks." 134 | function clike_expand_template_trules(env, nm, targs, fargs, addtypecheck) 135 | { 136 | <[deftargs;deftfargs;tbody]> = clike_get_template_defn(nm); 137 | // 1. Bind targs to their values; 138 | // A smaller number of template parameters can be provided, 139 | // in this case unbound parameters must be infered from the function 140 | // argument types. 141 | // 142 | // E.g., template A add(A x, A y) { return x + y; } 143 | // 144 | // can be used as add<>(2.0,2.0), with A resolving to '(float fp32)' 145 | getid(v) = cadr(v); 146 | gettp(v) = match v with 147 | typename(nm) -> 'typename' 148 | | typed(nm, tp) -> 'expr'(tp); 149 | gettypeval(v) = match v with 150 | type(t) -> t 151 | | else -> ccerror('NOT-A-TYPE'(v)); 152 | getexprval(v) = match v with 153 | expr(e) -> clike_untype_llexpr(e) 154 | | else -> ccerror('NOT-AN-EXPR'(v)); 155 | getexprtype(v) = match v with 156 | expr(e) -> car(e) 157 | | else -> ccerror('NOT-AN-EXPR'(v)); 158 | bindtypes = mkhash();bindexprs = mkhash(); 159 | bind(dst, src) = { 160 | nm = getid(dst); 161 | tp = gettp(dst); 162 | match tp with 163 | 'typename' -> ohashput(bindtypes, nm, gettypeval(src)) 164 | | expr(etp) -> { 165 | addtypecheck('typeeq'(etp, getexprtype(src))); 166 | ohashput(bindexprs, nm, getexprval(src)) }}; 167 | do_unbound(rst) = 168 | iter r in rst do { 169 | nm = getid(r); tp = gettp(r); 170 | match tp with 171 | 'typename' -> ohashput(bindtypes, nm, '*unbound*') 172 | | else -> ccerror('IMPLICIT-TEMPLATE-EXPR-ARGUMENT'(nm))}; 173 | do loop(d = deftargs, s = targs) { 174 | match s with 175 | hd: tl -> {bind(car(d), hd); loop(cdr(d), tl)} 176 | | [] -> do_unbound(d)}; 177 | // 1.1. Typecheck function arguments, bind the remaining types. 178 | l1 = length(deftfargs); l2 = length(fargs); 179 | if (not(l1==l2)) ccerror('TODO-IMPLEMENT-POLYMORPHIC-FUNCTIONS'(l1,l2)); 180 | subst_tvars(df) = { 181 | unb = mkref([]); 182 | ret = visit:clike (lltype: df) { 183 | deep lltype { 184 | alias -> 185 | aif(chk = ohashget(bindtypes, x)) { 186 | if (chk === '*unbound*') { 187 | unb := true; 188 | return node 189 | } else chk} 190 | | else -> node}}; 191 | return [^unb; ret]}; 192 | matchtype(tl, tr) = 193 | clike_type_iso_match(bindtypes, clike_template_unitype(env, bindtypes, tl), 194 | clike_env_unitype(env, tr)); 195 | z = zip(deftfargs, fargs); 196 | // TODO! Allow integer parameters in type 197 | // definitions (array lengths, ...) 198 | iter [df;fa] in z do { 199 | <[c;df1]> = subst_tvars(df); 200 | if(not(c)) { // type is complete, just typecheck it 201 | addtypecheck('typeeq'(df1, getexprtype(fa))); 202 | } else { 203 | // Incomplete type, infer its value 204 | matchtype(df1, getexprtype(fa)); 205 | } 206 | }; 207 | incomplete = mkref([]); 208 | hashiter(fun(k,v) if(v==='*unbound*') incomplete:=true, bindtypes); 209 | if (^incomplete) ccerror('TEMPLATE-CANNOT-INFER-TYPES'()); 210 | 211 | // 2. Once all the variables are substituted with either types or 212 | // expressions, we first produce a hash key and check if such an 213 | // instantiation is already available. In this case, just return the 214 | // types to complete the typing rules pass. 215 | // 216 | // If instantiation is required, substitute the type/expression variables 217 | // with their values in the template body, and store it in the hash. 218 | // Then, the first expand call will instantiate into a lift expression. 219 | getrettype(fn) = { 220 | visit:clike(lltoplev: fn) { 221 | once lltoplev { 222 | cfunc -> ret 223 | | else -> ccerror('IMPOSSIBLE'())}}}; 224 | sig = map d in deftargs do { 225 | id = getid(d); 226 | tp = gettp(d); 227 | match tp with 228 | 'typename' -> clike_env_unitype(env, ohashget(bindtypes, id)) 229 | | else -> ohashget(bindexprs, id)}; 230 | ssig = %S<<(nm,"|",strinterleave(map s in sig do %S<<(s),"|")); 231 | aif(chk = ohashget(clike_template_insts, ssig)) { 232 | return [ssig;getrettype(cadr(chk))]; 233 | } else { 234 | body = clike_template_instantiate(env, tbody, bindtypes, bindexprs); 235 | ohashput(clike_template_insts, ssig, 'new'(body)); 236 | return [ssig;getrettype(body)]}} 237 | 238 | ## 239 | %"Post--typing macro expansion phase; Lift a new toplevel def if needed, 240 | otherwise just substitute a call" 241 | function clike_template_subst(env, fargsv, sig) 242 | { 243 | tdef = ohashget(clike_template_insts, sig); 244 | rename(t, newnm) = 245 | visit:clike(lltoplev: t) { 246 | once lltoplev { 247 | cfunc -> mk:node(name = newnm) 248 | | else -> ccerror('IMPOSSIBLE'())}}; 249 | match tdef with 250 | 'new'(fbody) -> symbols(fnm) { 251 | nbody = rename(fbody, fnm); 252 | ohashput(clike_template_insts, sig, 'inst'(nbody, fnm)); 253 | return 'inblock'([], 'toplift'(nbody), 254 | 'call'([],fnm,@fargsv))} 255 | | 'inst'(b, fnm) -> 'call'([],fnm,@fargsv)} 256 | 257 | 258 | ##function clike_template_t_rule(env, args, macroenv) 259 | collector(addtypecheck, getchecks) { 260 | // 1. Parse args 261 | = args; 262 | = do loop(r = rargs, ta = []) { 263 | match r with 264 | 'verb'('*COMMA*'):tl -> reverse(ta):tl 265 | | hd:tl -> loop(tl, hd:ta) 266 | | [] -> reverse(ta):[]}; 267 | // 2. Get the return type 268 | <[ssig;rettype]> = clike_expand_template_trules(env, nm, targs, fargs, addtypecheck); 269 | macroenv := [nm;targs;fargs;ssig]; 270 | // 3. Type-check 271 | chks = getchecks(); 272 | iter c in chks do { 273 | match c with 274 | typeeq(tp, etp) -> { 275 | t1 = clike_env_unitype(env, tp); 276 | t2 = clike_env_unitype(env, etp); 277 | if (not(clike_type_iso(t1, t2))) ccerror('TEMPLATE-ARG-TYPE'(t1, t2))}}; 278 | // 4. Done 279 | return rettype} 280 | 281 | 282 | ##function clike_template_expand(env, rtype, args, macroenv) 283 | { 284 | <[nm;targs;fargs;sig]> = ^macroenv; 285 | fargsv = map expr(vl) in fargs do clike_untype_llexpr(vl); 286 | ret = clike_template_subst(env, fargsv, sig); 287 | return ret} 288 | 289 | ##{ 290 | hashput(clike_default_mcenv,%S<<(" :typrules: expand_template_app"), 291 | clike_template_t_rule); 292 | hashput(clike_default_mcenv,%S<<(" :typexpander: expand_template_app"), 293 | clike_template_expand)} 294 | 295 | --------------------------------------------------------------------------------