Mercurial > repos > icfp2014
view code/gcc.tp @ 43:6d2cbad5fca9
WIP version of a compiler for the LamCo GCC
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Sun, 27 Jul 2014 01:50:49 -0700 |
parents | |
children | ec87d53603dd |
line wrap: on
line source
#{ new <- :code { consUsage <- 0 dataStack <- [] controlStack <- 0 stackSize <- 0 pc <- 0 error <- :_msg { #{ msg <- { _msg } isInteger? <- { false } isError? <- { true } isClosure? <- { false } isEnvironment? <- { false } isCons? <- { false } isJoin? <- { false } isStop? <- { false } tag <- { "ERROR" } } } _dummy <- #{ isInteger? <- { false } isError? <- { false } isClosure? <- { false } isEnvironment? <- { false } isCons? <- { false } isJoin? <- { false } isStop? <- { false } tag <- { "DUMMY" } } getTag <- :val { if: (val isInteger?) { "INTEGER" } else: { val tag } } push <- :val { dataStack <- val | dataStack stackSize <- stackSize + 1 } pop <- { if: (dataStack empty?) { error: "datastack empty" } else: { ret <- dataStack value dataStack <- dataStack tail stackSize <- stackSize - 1 ret } } _curEnv <- #{ ld <- :envNum slotNum { error: "invalid environment" } st <- :envNum slotNum val { error: "invalid environment" } rapLoad <- { error: "invalid environment" } isError? <- { false } isEnvironment? <- { true } isJoin? <- { false } isReturn? <- { false } isStop? <- { false } tag <- { "TOPENV" } } cons <- :_car _cdr { consUsage <- consUsage + 1 #{ car <- { _car } cdr <- { _cdr } isInteger? <- { false } isError? <- { false } isClosure? <- { false } isEnvironment? <- { false } isCons? <- { true } isJoin? <- { false } tag <- { "CONS" } } } env:dummy? <- :_size _parent :_dummy? { consUsage <- consUsage + 1 + _size / 2 _arr <- #[] _hasError <- false _error <- false if: _size > 0 { _arr resize: _size i <- 0 while: { i < _size } do: { _arr append: 0 i <- i + 1 } if: (not: _dummy?) { i <- _size - 1 while: { (not: _hasError) && i >= 0 } do: { val <- pop: if: ((not: (val isInteger?)) && (val isError?)) { _error <- error: "data stack empty while populating env at slot " . i . " of " . _size _hasError <- true } else: { _arr set: i val i <- i - 1 } } } } if: _hasError { _error } else: { #{ != <- :other { //TODO: implement me properly tag != (other tag) } ld <- :envNum slotNum { if: envNum > 0 { _parent ld: envNum - 1 slotNum } else: { if: _dummy? { error: "attempt to ld from dummy env" } else: { if: slotNum < _size { _arr get: slotNum } else: { error: "attempt to access invalid slot " . slotNum . " in env of size " . _size } } } } st <- :envNum slotNum val { if: envNum > 0 { _parent st: envNum - 1 slotNum val } else: { if: _dummy? { error: "attempt to st to dummy env" } else: { if: slotNum < _size { _arr set: slotNum val _dummy } else: { error: "attempt to access invalid slot " . slotNum . " in env of size " . _size } } } } rapLoad <- :rapSize { if: _dummy? { if: rapSize != _size { _hasError <- true _error <- error: "frame size mismatch for RAP instruction" } else: { i <- 0 i <- _size - 1 while: { (not: _hasError) && i >= 0 } do: { val <- pop: if: ((not: (val isInteger?)) && (val isError?)) { _error <- error: "data stack empty while populating env at slot " . i . " of " . _size _hasError <- true } else: { _arr set: i val i <- i - 1 } } _dummy? <- false } } else: { _hasError <- true _error <- error: "attempt to RAP into non-dummy environment" } if: _hasError { _error } else: { _dummy } } isError? <- { false } isEnvironment? <- { true } isJoin? <- { false } isReturn? <- { false } isStop? <- { false } tag <- { "ENVIRONMENT" } } } } closure <- :_address { _env <- _curEnv #{ address <- { _address } env <- { _env } isInteger? <- { false } isError? <- { false } isClosure? <- { true } isEnvironment? <- { false } isCons? <- { false } isJoin? <- { false } tag <- { "CLOSURE" } } } join <- :_address { #{ address <- { _address } isError? <- { false } isEnvironment? <- { false } isJoin? <- { true } isReturn? <- { false } isStop? <- { false } tag <- { "JOIN" } } } return <- :_address { #{ address <- { _address } isError? <- { false } isEnvironment? <- { false } isJoin? <- { false } isReturn? <- { true } isStop? <- { false } tag <- { "RETURN" } } } stop <- #{ isError? <- { false } isEnvironment? <- { false } isJoin? <- { false } isReturn? <- { false } isStop? <- { true } tag <- { "STOP" } } _instConstructors <- dict hash _instConstructors set: "LDC" :args { _const <- args get: 0 { push: _const _dummy } } _instConstructors set: "LD" :args { _env <- args get: 0 _slot <- args get: 1 { val <- _curEnv ld: _env _slot if: (not: (val isInteger?)) && (val isError?) { val } else: { push: val _dummy } } } _instConstructors set: "ST" :args { _env <- args get: 0 _slot <- args get: 1 { val <- pop: if: (not: (val isInteger?)) && (val isError?) { val } else: { _curEnv st: _env _slot val } } } binaryConstruct <- macro: :name op a b{ quote: (_instConstructors set: name :args { { a <- pop: if: (a isInteger?) { b <- pop: if: (b isInteger?) { push: op _dummy } else: { if: (b isError?) { b } else: { error: "Got wrong type for left param of " . name . " instruction" } } } else: { if: (a isError?) { a } else: { error: "Got wrong type for right param of " . name . " instruction" } } } }) } binaryConstruct: "ADD" b + a a b binaryConstruct: "SUB" b - a a b binaryConstruct: "MUL" b * a a b binaryConstruct: "DIV" b / a a b binaryConstruct: "CEQ" (if: b = a { 1 } else: { 0 }) a b binaryConstruct: "CGT" (if: b > a { 1 } else: { 0 }) a b binaryConstruct: "CGTE" (if: b >= a { 1 } else: { 0 }) a b _instConstructors set: "ATOM" :args { { val <- pop: if: (val isInteger?) { push: 1 _dummy } else: { if: (val isError?) { val } else: { push: 0 _dummy } } } } _instConstructors set: "CONS" :args { { a <- pop: if: ((not: (a isInteger?)) && (a isError?)) { a } else: { b <- pop: if: ((not: (b isInteger?)) && (b isError?)) { b } else: { push: (cons: b a) _dummy } } } } _instConstructors set: "CAR" :args { { val <- pop: if: (val isInteger?) { error: "CAR expects CONS cell, got INTEGER instead" } else: { if: (val isError?) { val } else: { if: (val isCons?) { push: (val car) _dummy } else: { error: "CAR expects CONS cell, got " . (val tag) . " instead" } } } } } _instConstructors set: "CDR" :args { { val <- pop: if: (val isInteger?) { error: "CDR expects CONS cell, got integer instead" } else: { if: (val isError?) { val } else: { if: (val isCons?) { push: (val cdr) _dummy } else: { error: "CDR expects CONS cell, got " . (val tag) . " instead" } } } } } _instConstructors set: "SEL" :args { _t <- args get: 0 _f <- args get: 1 { val <- pop: if: (val isInteger?) { controlStack <- cons: (join: pc) controlStack pc <- if: (val != 0) { _t } else: { _f } _dummy } else: { if: (val isError?) { val } else: { error: "SEL expects INTEGER, got " . (val tag) . " instead" } } } } _instConstructors set: "TSEL" :args { _t <- args get: 0 _f <- args get: 1 { val <- pop: if: (val isInteger?) { pc <- if: (val != 0) { _t } else: { _f } _dummy } else: { if: (val isError?) { val } else: { error: "TSEL expects INTEGER, got " . (val tag) . " instead" } } } } _instConstructors set: "JOIN" :args { { if: (controlStack isInteger?) { error: "JOIN tried to pull value from empty control stack" } else: { val <- controlStack car controlStack <- controlStack cdr if: (val isJoin?) { pc <- val address _dummy } else: { error: "JOIN expects JOIN cell, got " . (val tag) . " instead" } } } } _instConstructors set: "LDF" :args { _address <- args get: 0 { push: (closure: _address) _dummy } } _instConstructors set: "AP" :args { _envSize <- args get: 0 { val <- pop: if: (val isInteger?) { error: "AP expects CLOSURE, got INTEGER instead" } else: { if: (val isError?) { val } else: { if: (val isClosure?) { frame <- env: _envSize (val env) dummy?: false if: (frame isError?) { frame } else: { controlStack <- cons: (return: pc+1) (cons: _curEnv controlStack) _curEnv <- frame pc <- val address _dummy } } else: { error: "AP expects CLOSURE, got " . (val tag) . " instead" } } } } } _instConstructors set: "TAP" :args { _envSize <- args get: 0 { val <- pop: if: (val isInteger?) { error: "TAP expects CLOSURE, got INTEGER instead" } else: { if: (val isError?) { val } else: { if: (val isClosure?) { frame <- env: _envSize (val env) dummy?: false if: (frame isError?) { frame } else: { _curEnv <- frame pc <- val address _dummy } } else: { error: "TAP expects CLOSURE, got " . (val tag) . " instead" } } } } } _instConstructors set: "RTN" :args { { if: (controlStack isInteger?) { error: "control stack is empty for RTN instruction" } else: { val <- controlStack car controlStack <- controlStack cdr if: (val isReturn?) { _curEnv <- controlStack car controlStack <- controlStack cdr pc <- val address _dummy } else: { if: (val isStop?) { val } else: { error: "RTN expects RETURN, got " . (val tag) . " instead" } } } } } _instConstructors set: "DUM" :args { _envSize <- args get: 0 { frame <- env: _envSize _curEnv dummy?: true if: (frame isError?) { frame } else: { _curEnv <- frame _dummy } } } _instConstructors set: "RAP" :args { _envSize <- args get: 0 { val <- pop: if: (val isInteger?) { error: "RAP expects CLOSURE, got INTEGER instead" } else: { if: (val isError?) { val } else: { if: (val isClosure?) { res <- _curEnv rapLoad: _envSize if: (not: (res isError?)) { if: (val env) != _curEnv { res <- error: "CLOSURE environment must equal current environment for RAP" } else: { controlStack <- cons: (return: pc+1) (cons: (_curEnv parent) controlStack) pc <- val address } } res } else: { error: "RAP expects CLOSURE, got " . (val tag) . " instead" } } } } } _instConstructors set: "TRAP" :args { _envSize <- args get: 0 { val <- pop: if: (val isInteger?) { error: "RAP expects CLOSURE, got INTEGER instead" } else: { if: (val isError?) { val } else: { if: (val isClosure?) { res <- _curEnv rapLoad: _envSize if: (not: (res isError?)) { if: (val env) != _curEnv { res <- error: "CLOSURE environment must equal current environment for RAP" } else: { pc <- val address } } res } else: { error: "RAP expects CLOSURE, got " . (val tag) . " instead" } } } } } _instConstructors set: "STOP" :args { { stop } } _instConstructors set: "DBUG" :args { { val <- pop: if: (not: (val isInteger?)) && (val isError?) { val } else: { print: (string: val) . "\n" _dummy } } } _instConstructors set: "BRK" :args { { _dummy } } code <- code map: :i { foobar <- _instConstructors get: (i inst) else: { { stop } } foobar: (i args) } #{ limit <- 3072 * 1000 run <- { cycles <- 0 status <- _dummy while: { (not: (status isError?)) && (not: (status isStop?)) } do: { oldpc <- pc if: (cycles >= limit) { status <- error: "cycle limit of " . limit . " exceeded" } else: { if: (pc >= (code length)) { status <- error: "PC walked off end of program" } else: { inst <- code get: pc pc <- -1 status <- inst: if: pc = -1 { pc <- oldpc + 1 } cycles <- cycles + 1 } } } print: "Status: " . (status tag) . "\n" if: (status isStop?) { if: (dataStack empty?) { _dummy } else: { pop: } } else: { status } } } } parseLines <- :lines { //remove comments and filter blank lines lines <- (lines map: :line { ((line partitionOn: ";") before) trim }) filter: :line { line != "" } //parse the preprocessed lines lines map: :line { ret <- line partitionOn: " " _inst <- ret before _args <- (((ret after) trim) splitOn: " ") map: :arg { int32: arg } #{ inst <- { _inst } args <- { _args } } } } parseFile <- :f { parseLines: (f lines) } main <- :args { if: (args length) > 1 { f <- file open: (args get: 1) if: (f fd) >= 0 { code <- parseFile: f cpu <- new: code res <- cpu run print: "Returned value of type: " . (res tag) . "\n" if: (res isError?) { print: (res msg) . "\n" } 0 } else: { (file stderr) write: "Failed to open " . (args get: 1) . " for reading\n" 1 } } else: { (file stderr) write: "USAGE: gcc FILE\n" 1 } } }