Mercurial > repos > icfp2014
view code/gcc.tp @ 76:47eb447a74cc
Don't chase ghosts we can't catch
author | Michael Pavone <pavone@retrodev.com> |
---|---|
date | Mon, 28 Jul 2014 02:57:56 -0700 |
parents | ec87d53603dd |
children |
line wrap: on
line source
#{ getTag <- :val { if: (val isInteger?) { "INTEGER" } else: { val tag } } ifError:else <- :val iferr :else { if: (val isInteger?) { else: } else: { if: (val isError?) { iferr: } else: { else: } } } new <- :rawCode { 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" } string <- { _msg } } } _dummy <- #{ isInteger? <- { false } isError? <- { false } isClosure? <- { false } isEnvironment? <- { false } isCons? <- { false } isJoin? <- { false } isStop? <- { false } tag <- { "DUMMY" } string <- { 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" } arr <- { #[] } isError? <- { false } isEnvironment? <- { true } isJoin? <- { false } isReturn? <- { false } isStop? <- { false } tag <- { "TOPENV" } string <- { tag } } cons <- :_car _cdr { consUsage <- consUsage + 1 #{ car <- { _car } cdr <- { _cdr } isInteger? <- { false } isError? <- { false } isClosure? <- { false } isEnvironment? <- { false } isCons? <- { true } isJoin? <- { false } tag <- { "CONS" } string <- { "(" . _car . ", " . _cdr . ")" } } } 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" } string <- { tag } arr <- { _arr } } } } closure <- :_address { _env <- _curEnv #{ address <- { _address } env <- { _env } isInteger? <- { false } isError? <- { false } isClosure? <- { true } isEnvironment? <- { false } isCons? <- { false } isJoin? <- { false } tag <- { "CLOSURE" } string <- { "{" . _address . ", " . _env . "}" } } } joinVal <- :_address { #{ address <- { _address } isError? <- { false } isEnvironment? <- { false } isJoin? <- { true } isReturn? <- { false } isStop? <- { false } tag <- { "JOIN" } string <- { tag } } } return <- :_address { #{ address <- { _address } isError? <- { false } isEnvironment? <- { false } isJoin? <- { false } isReturn? <- { true } isStop? <- { false } tag <- { "RETURN" } string <- { tag . " " . _address } } } stop <- #{ isError? <- { false } isEnvironment? <- { false } isJoin? <- { false } isReturn? <- { false } isStop? <- { true } tag <- { "STOP" } string <- { tag } } _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: (joinVal: _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) (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) (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 <- rawCode map: :i { foobar <- _instConstructors get: (i inst) else: { { stop } } foobar: (i args) } _stepMode? <- false _lastCommand <- "" _breakFun <- :cpu { i <- (rawCode get: (cpu pc)) print: (string: (cpu pc)) . ": " . (i inst) . " " . ((i args) join: " ") . "\n" command <- "" while: { command != "c" && command != "s"} do: { command <- ((file stdin) nextLine) trim if: command = "" { command <- _lastCommand } else: { _lastCommand <- command } if: command = "d" { print: "Data Stack:\n" ds <- cpu dstack while: { not: (ds empty?) } do: { print: "\t" . (ds value) . "\n" ds <- ds tail } } if: command = "b" { print: "Control Stack:\n" cs <- cpu cstack while: { not: (cs isInteger?) } do: { print: "\t" . (cs car) . "\n" cs <- cs cdr } } if: command = "e" { print: "Environment:\n" env <- cpu environment foreach: ((cpu environment) arr) :idx val { print: "\t" . idx . ": " . val . "\n" } } } if: command = "c" { cpu runMode } } _cycles <- 0 #{ limit <- 3072 * 1000 stepMode <- { _stepMode? <- true self } runMode <- { _stepMode? <- false self } breakFun <- _breakFun pc <- { _pc } dstack <- { dataStack } cstack <- { controlStack } environment <- { _curEnv } cycles <- { _cycles } run <- { _cycles <- 0 controlStack <- cons: stop 0 status <- _dummy while: { (not: (status isError?)) && (not: (status isStop?)) } do: { if: _stepMode? { break <- breakFun break: self } 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 <- _pc + 1 status <- inst: _cycles <- _cycles + 1 } } } 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 if: (args length) > 2 { cpu stepMode } res <- cpu run print: "Ran for " . (cpu cycles) . " cycles\n" print: "Returned value of type: " . (getTag: res) . " - value: " . res . "\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 } } }