# HG changeset patch # User Steve Losh # Date 1468360561 0 # Node ID 184e610451c0693356c9930e3300d730ad8ac9bd # Parent a02637eeccca3f3869dd2878256fceda55ee3ebb Initial poke at Lispifying the code store Actually makes things a lot slower and uglier for now, but this will be fixed once everything is converted over (I hope). diff -r a02637eeccca -r 184e610451c0 src/wam/compiler.lisp --- 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)) diff -r a02637eeccca -r 184e610451c0 src/wam/dump.lisp --- 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" diff -r a02637eeccca -r 184e610451c0 src/wam/types.lisp --- 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 (*))) diff -r a02637eeccca -r 184e610451c0 src/wam/vm.lisp --- 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))