--- a/src/wam/compiler.lisp Tue Jul 12 18:53:39 2016 +0000
+++ b/src/wam/compiler.lisp Tue Jul 12 21:56:01 2016 +0000
@@ -1142,7 +1142,7 @@
;; [CALL/JUMP] functor
(push-instruction
(if is-jump :jump :call)
- (wam-ensure-functor-index wam (cons functor arity))))
+ (cons functor arity)))
;; This is a little janky, but at this point the body goals have been
;; turned into one single stream of tokens, so we don't have a nice
;; clean way to tell when one ends. But in practice, a body goal is
@@ -1522,15 +1522,17 @@
(defun* render-argument (argument)
(:returns code-word)
(etypecase argument
+ ;; todo: simplify this to a single `if` once the store is fully split
(null 0) ; ugly choice point args that'll be filled later...
(register (register-number argument)) ; bytecode just needs register numbers
+ (functor argument) ; functor for a CALL/JUMP
(number argument))) ; just a numeric argument, e.g. alloc 0
-(defun* render-bytecode ((code generic-code-store)
+(defun* render-bytecode ((store generic-code-store)
(instructions circle)
(start code-index)
(limit code-index))
- "Render `instructions` (a circle) into `code` starting at `start`.
+ "Render `instructions` (a circle) into `store` starting at `start`.
Bail if ever pushed beyond `limit`.
@@ -1541,36 +1543,36 @@
(flet
((fill-previous-jump (address)
(when previous-jump
- (setf (aref code (1+ previous-jump)) address))
+ (setf (aref store (1+ previous-jump)) address))
(setf previous-jump address)))
(loop
:with address = start
;; Render the next instruction
- :for (opcode . arguments) :in (circle-to-list instructions)
- :for size = (code-push-instruction code
- (render-opcode opcode)
- (mapcar #'render-argument arguments)
- address)
+ :for (opcode-designator . arguments) :in (circle-to-list instructions)
+ :for opcode = (render-opcode opcode-designator)
+ :for size = (instruction-size opcode)
:summing size
+ ;; Make sure we don't run past the end of our section.
+ :when (>= (+ size address) limit)
+ :do (error "Code store exhausted, game over.")
+
+ :do (code-push-instruction store
+ opcode
+ (mapcar #'render-argument arguments)
+ address)
+
;; We need to fill in the addresses for the choice point jumping
;; instructions. For example, when we have TRY ... TRUST, the TRUST
;; needs to patch its address into the TRY instruction.
;;
;; I know, this is ugly, sorry.
- :when (member opcode '(:try :retry :trust))
+ :when (member opcode-designator '(:try :retry :trust))
:do (fill-previous-jump address)
;; look, don't judge me, i told you i know its bad
- :do (incf address size)
-
- ;; Make sure we don't run past the end of our section.
- ;;
- ;; TODO: move this check up higher so we don't accidentally
- ;; push past the query boundary
- :when (>= address limit)
- :do (error "Code store exhausted, game over.")))))
+ :do (incf address size)))))
(defun* render-query ((wam wam) (instructions circle))
--- a/src/wam/dump.lisp Tue Jul 12 18:53:39 2016 +0000
+++ b/src/wam/dump.lisp Tue Jul 12 21:56:01 2016 +0000
@@ -143,8 +143,13 @@
(elt functor-list functor-index)
(format nil "~A/~D" symbol arity))))
+(defun pretty-argument (argument)
+ (typecase argument
+ (fixnum (format nil "~4,'0X" argument))
+ (t (format nil "#<*>"))))
+
(defun pretty-arguments (arguments)
- (format nil "~10<~{ ~4,'0X~}~;~>" arguments))
+ (format nil "~10<~{ ~A~}~;~>" (mapcar #'pretty-argument arguments)))
(defgeneric instruction-details (opcode arguments functor-list))
@@ -218,12 +223,12 @@
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
(format nil "CALL~A ; call ~A"
(pretty-arguments arguments)
- (pretty-functor (first arguments) functor-list)))
+ (first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments functor-list)
(format nil "JUMP~A ; jump ~A"
(pretty-arguments arguments)
- (pretty-functor (first arguments) functor-list)))
+ (first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments functor-list)
(format nil "DYCL~A ; dynamic call"
--- a/src/wam/types.lisp Tue Jul 12 18:53:39 2016 +0000
+++ b/src/wam/types.lisp Tue Jul 12 21:56:01 2016 +0000
@@ -40,13 +40,14 @@
'(cons symbol arity))
-(deftype code-word ()
- `(unsigned-byte ,+code-word-size+))
-
(deftype code-index ()
;; either an address or the sentinel
`(integer 0 ,(1- +code-limit+)))
+(deftype code-word ()
+ t)
+
+
(deftype generic-code-store ()
`(simple-array code-word (*)))
--- a/src/wam/vm.lisp Tue Jul 12 18:53:39 2016 +0000
+++ b/src/wam/vm.lisp Tue Jul 12 21:56:01 2016 +0000
@@ -1,7 +1,7 @@
(in-package #:bones.wam)
;;;; Config
-(defparameter *step* nil)
+(defvar *step* nil)
;;;; Utilities
@@ -479,10 +479,11 @@
(defun* %%procedure-call ((wam wam)
- (functor functor-index)
+ (functor functor)
(program-counter-increment instruction-size)
(is-tail boolean))
- (let ((target (wam-code-label wam functor)))
+ (let* ((findex (wam-ensure-functor-index wam functor))
+ (target (wam-code-label wam findex)))
(if (not target)
;; Trying to call an unknown procedure.
(backtrack! wam)
@@ -491,7 +492,7 @@
(setf (wam-continuation-pointer wam) ; CP <- next instruction
(+ (wam-program-counter wam) program-counter-increment)))
(setf (wam-number-of-arguments wam) ; set NARGS
- (wam-functor-arity wam functor)
+ (wam-functor-arity wam findex)
(wam-cut-pointer wam) ; set B0 in case we have a cut
(wam-backtrack-pointer wam)
@@ -519,11 +520,11 @@
:for argument-address :from (1+ functor-address)
:do (setf (wam-local-register wam argument-register)
(wam-heap-cell wam argument-address)))
- (%go functor))))
+ (%go (wam-functor-lookup wam functor)))))
((cell-constant-p cell)
;; Zero-arity functors don't need to set up anything at all -- we can
;; just call them immediately.
- (%go (cell-value cell)))
+ (%go (wam-functor-lookup wam (cell-value cell))))
((cell-reference-p cell)
;; It's okay to do (call :var), but :var has to be bound by the time you
;; actually reach it at runtime.
@@ -532,10 +533,10 @@
(error "Cannot dynamically call something other than a structure."))))))
-(define-instruction (%jump) ((wam wam) (functor functor-index))
+(define-instruction (%jump) ((wam wam) (functor functor))
(%%procedure-call wam functor (instruction-size +opcode-jump+) t))
-(define-instruction (%call) ((wam wam) (functor functor-index))
+(define-instruction (%call) ((wam wam) (functor functor))
(%%procedure-call wam functor (instruction-size +opcode-call+) nil))
@@ -761,7 +762,7 @@
(not (= pc +code-sentinel+))) ; finished
:for opcode = (aref code pc) ; todo switch this to wam-code-word...
:do
- (block op
+ (progn
(when *step*
(dump) ; todo: make this saner
(break "About to execute instruction at ~4,'0X" pc))