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
		}
	}
}