Mercurial > repos > tabletprog
view modules/llcompile.tp @ 353:95bc24c729e6
Move right hand parameter to cmp in _compileBinary to a temp reg if it is a constant since those are only supported in the left hand param currently
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Tue, 14 Apr 2015 19:54:03 -0700 |
parents | f74ce841fd1e |
children | a6cdcc1b1c02 |
line wrap: on
line source
{ _compileError <- :_msg _line { #{ isError? <- { true } msg <- { _msg } line <- { _line } } } _notError:else <- :vals ifnoterr iferror { if: (object does: vals understand?: "find") { maybeErr <- vals find: :val { (object does: val understand?: "isError?") && (val isError?) } maybeErr value: :err { iferror: err } none: ifnoterr } else: ifnoterr } _notError <- :vals ifnoterr { _notError: vals ifnoterr else: :e { e } } _ilFun <- :_name { _buff <- #[] _blockStack <- [] _nextReg <- 0 #{ name <- { _name } add <- :inst { _buff append: inst } getReg <- { r <- il reg: _nextReg _nextReg <- _nextReg + 1 r } startBlock <- { _blockStack <- _buff | _blockStack _buff <- #[] } popBlock <- { res <- _buff _buff <- _blockStack value _blockStack <- _blockStack tail res } buffer <- { _buff } } } _sizeMap <- dict hash _sizeMap set: "8" (il b) _sizeMap set: "16" (il w) _sizeMap set: "32" (il l) _sizeMap set: "64" (il q) _parseType <- :expr { if: (expr nodeType) = (ast sym) { name <- expr name _signed? <- true if: (name startsWith?: "u") { _signed? <- false name <- name from: 1 } if: (name startsWith?: "int") && ((name length) <= 5) { size <- name from: 3 _sizeMap ifget: size :llsize { #{ size <- llsize signed? <- _signed? } } else: { _compileError: "LL integer type " . (expr name) . " has an invalid size" } } else: { _compileError: "LL Type " . (expr name) . " not implemented yet" } } else: { _compileError: "LL Type with node type " . (expr nodeType) . " not implemented yet" } } _exprHandlers <- false _compileExpr:syms:ilfun:dest <- :expr :syms :ilf :dst { _exprHandlers ifget: (expr nodeType) :handler { handler: expr syms ilf dst } else: { _compileError: "Expression with node type " . (expr nodeType) . " not implemented yet" } } _opMap <- false _compOps <- false _compileBinary <- :expr syms ilf assignTo { _assignSize? <- false _asize <- il b dest <- assignTo value: :asn { _assignSize? <- true _asize <- asn size asn } none: { #{ val <- ilf getReg signed? <- true size <- _asize } } l <- _compileExpr: (expr left) syms: syms ilfun: ilf dest: (option value: dest) r <- _compileExpr: (expr right) syms: syms ilfun: ilf dest: (option none) _notError: [(l) (r)] { lv <- l val ls <- l size rv <- r val rs <- r size _size <- if: ls > rs { ls //TODO: sign/zero extend rv } else: { rs //TODO: sign/zero extend lv if rs > ls } if: _assignSize? && _asize > _size { _size <- _asize //TODO: sign/zero extend result } _signed <- (l signed?) || (r signed?) _opMap ifget: (expr op) :ingen { ilf add: (ingen: lv rv (dest val) _size) #{ val <- dest val size <- _size signed? <- _signed } } else: { _compOps ifget: (expr op) :condFun { if: (rv isInteger?) { tmp <- rv rv <- ilf getReg ilf add: (il mov: tmp rv rs) } ilf add: (il cmp: lv rv _size) cond <- condFun: _signed ilf add: (il bool: cond (dest val)) #{ val <- dest val size <- il b signed? <- false } } else: { _compileError: "Operator " . (expr op) . " is not supported yet\n" 0 } } } } _compileString <- :expr syms ilf assignTo { } _compileInt <- :expr syms ilf assignTo { sz <- il sizeFromBytes: (expr size) assignTo value: :asn { ilf add: (il mov: (expr val) (asn val) sz) #{ val <- asn val signed? <- expr signed? size <- sz } } none: { #{ val <- expr val signed? <- expr signed? size <- sz } } } _compileSym <- :expr syms ilf assignTo { syms ifDefined: (expr name) :syminfo { if: (syminfo isLocal?) { syminfo def } else: { print: "Symbol " . (expr name) . " is not local and other types are not yet supported in LL dialect\n" } } else: { _compileError: "Symbol " . (expr name) . " is not defined in " . (ilf name) } } _compileIf <- :expr syms ilf assignTo { if: ((expr args) length) != 2 { _compileError: "if takes exactly 2 arguments" 0 } else: { condArg <- (expr args) value blockArg <- ((expr args) tail) value cond <- _compileExpr: condArg syms: syms ilfun: ilf dest: (option none) _notError: [cond] { if: (blockArg nodeType) != (ast lambda) { _compileError: "second argument to if must be a lambda" } else: { ilf add: (il cmp: 0 (cond val) (cond size)) dest <- if: (assignTo none?) { option value: #{ val <- ilf reg //TODO: FIXME size <- il q signed? <- true } } else: { assignTo } ilf startBlock foreach: (blockArg expressions) :idx expr{ asn <- if: idx = ((blockArg expressions) length) - 1 { dest } else: { option none } _compileExpr: expr syms: syms ilfun: ilf dest: asn } block <- ilf popBlock ilf add: (il skipIf: (il neq) block) dest value: :d { d } none: { _compileError: "Something went wrong" } } } } } _compileIfElse <- :expr syms ilf assignTo { if: ((expr args) length) != 3 { _compileError: "if:else takes exactly 3 arguments" 0 } else: { condArg <- (expr args) value blockArg <- ((expr args) tail) value elseArg <- (((expr args) tail) tail) value cond <- _compileExpr: condArg syms: syms ilfun: ilf dest: (option none) _notError: [cond] { if: (blockArg nodeType) != (ast lambda) { _compileError: "second argument to if:else must be a lambda" } else: { if: (elseArg nodeType) != (ast lambda) { _compileError: "third argument to if:else must be a lambda" } else: { ilf add: (il cmp: 0 (cond val) (cond size)) dest <- if: (assignTo none?) { option value: #{ val <- ilf reg //TODO: FIXME size <- il q signed? <- true } } else: { assignTo } ilf startBlock foreach: (blockArg expressions) :idx expr { asn <- if: idx = ((blockArg expressions) length) - 1 { dest } else: { option none } _compileExpr: expr syms: syms ilfun: ilf dest: asn } block <- ilf popBlock ilf startBlock foreach: (elseArg expressions) :idx expr { asn <- if: idx = ((elseArg expressions) length) - 1 { dest } else: { option none } _compileExpr: expr syms: syms ilfun: ilf dest: (option none) } elseblock <- ilf popBlock ilf add: (il skipIf: (il neq) block else: elseblock) dest value: :d { d } none: { _compileError: "Something went wrong" } } } } } } _funMap <- false _compileCall <- :expr syms ilf assignTo { if: ((expr tocall) nodeType) = (ast sym) && (_funMap contains?: ((expr tocall) name)) { handler <- _funMap get: ((expr tocall) name) else: { false } handler: expr syms ilf assignTo } else: { ctocall <- if: ((expr tocall) nodeType) = (ast sym) { ctocall <- (expr tocall) name } else: { _compileExpr: (expr tocall) syms: syms ilfun: ilf dest: (option none) } cargs <- (expr args) map: :arg { _compileExpr: arg syms: syms ilfun: ilf dest: (option none) } _notError: ctocall | cargs { ilf add: (il call: ctocall withArgs: (cargs map: :arg { arg val } )) retval <- assignTo value: :asn { ilf add: (il mov: (il retr) (asn val) (asn size)) asn } none: { #{ val <- il retr //TODO: Use correct values based on return type size <- il q signed? <- true } } retval } } } _compileAssign <- :expr syms ilf assignTo { dest <- _compileExpr: (expr to) syms: syms ilfun: ilf dest: (option none) _notError: [dest] { value <- _compileExpr: (expr assign) syms: syms ilfun: ilf dest: dest _notError: [value] { //TODO: adjust size of value if necessary //ilf add: (il mov: (value val) (dest val) (dest size)) value } } } _initDone? <- false #{ import: [ binary stringlit intlit sym call obj sequence assignment lambda ] from: ast _initHandlers <- { if: (not: _initDone?) { _exprHandlers <- dict hash _exprHandlers set: binary _compileBinary _exprHandlers set: stringlit _compileString _exprHandlers set: intlit _compileInt _exprHandlers set: sym _compileSym _exprHandlers set: assignment _compileAssign _exprHandlers set: call _compileCall _opMap <- dict hash mapOp <- macro: :op ilfun { quote: (_opMap set: op :ina inb out size { il ilfun: ina inb out size }) } mapOp: "+" add mapOp: "-" sub mapOp: "*" mul mapOp: "/" div mapOp: "and" band mapOp: "or" bor mapOp: "xor" bxor _compOps <- dict hash _compOps set: "=" :signed? { il eq } _compOps set: "!=" :signed? { il ne } _compOps set: ">" :signed? { if: signed? { il gr } else: { il ugr } } _compOps set: "<" :signed? { if: signed? { il ls } else: { il uls } } _compOps set: ">=" :signed? { if: signed? { il ge } else: { il uge } } _compOps set: "<=" :signed? { if: signed? { il le } else: { il ule } } _funMap <- dict hash _funMap set: "if" _compileIf _funMap set: "if:else" _compileIfElse //_funMap set: "while:do" _compileWhileDo } } llFun:syms:vars:code <- :name :syms :vars :code{ _initHandlers: syms <- symbols tableWithParent: syms argnames <- dict hash foreach: (code args) :idx arg { if: (arg startsWith?: ":") { arg <- arg from: 1 } argnames set: arg idx } ilf <- _ilFun: name _nextReg <- 0 varErrors <- (vars expressions) fold: [] with: :acc var { type <- _parseType: (var assign) _notError: [type] { varname <- ((var to) name) v <- argnames ifget: varname :argnum { il arg: argnum } else: { ilf getReg } syms define: varname #{ val <- v size <- (type size) signed? <- (type signed?) } acc } else: :err { err | acc } } if: (varErrors empty?) { last <- option none numexprs <- (code expressions) length foreach: (code expressions) :idx expr { asn <- if: idx = numexprs - 1 { option value: #{ val <- ilf getReg //TODO: FIxme size <- il q signed? <- true } } else: { option none } last <- option value: (_compileExpr: expr syms: syms ilfun: ilf dest: asn) } last value: :v { ilf add: (il return: (v val) (v size)) } none: { ilf add: (il return: 0 (il l)) } ilf } else: { varErrors } } compileText <- :text { res <- parser top: text if: res { tree <- res yield if: (tree nodeType) = obj { errors <- [] syms <- symbols table functions <- (tree messages) fold: [] with: :curfuncs msg { if: (msg nodeType) = call { if: ((msg tocall) name) = "llFun:withVars:andCode" { if: ((msg args) length) = 3 { fname <- ((msg args) value) name syms define: fname #{ type <- "topfun" } rest <- (msg args) tail #{ name <- fname vars <- rest value body <- (rest tail) value } | curfuncs } else: { errors <- ( _compileError: "llFun:withVars:andCode takes exactly 3 arguments" 0 ) | errors curfuncs } } else: { errors <- ( _compileError: "Only llFun:withVars:andCode expressions are allowed in top level object" 0 ) | errors curfuncs } } else: { errors <- ( _compileError: "Only call expresions are allowed in top level object" 0 ) | errors curfuncs } } if: (errors empty?) { errors <- [] fmap <- functions fold: (dict hash) with: :acc func { ilf <- llFun: (func name) syms: syms vars: (func vars) code: (func body) _notError: ilf { acc set: (func name) (ilf buffer) } else: { errors <- ilf . errors } acc } if: (errors empty?) { foreach: fmap :name instarr { print: "Function: " . name . "\n" foreach: instarr :_ inst { print: "\t" . inst . "\n" } } print: "Translating IL to x86\n" il toBackend: fmap x86 } else: { errors } } else: { errors } } else: { [(_compileError: "Top level must be an object in llcompile dialect" 1)] } } else: { [(_compileError: "Failed to parse file" 0)] } } main <- :args { if: (length: args) > 1 { text <- (file open: (args get: 1)) readAll mcode <- compileText: text _notError: mcode { ba <- bytearray executableFromBytes: mcode arg <- if: (length: args) > 2 { int32: (args get: 2) } else: {0} ba runWithArg: (arg i64) } else: :err { (file stderr) write: (err msg) . "\n" } } else: { (file stderr) write: "Usage: llcompile FILE\n" 1 } } } }