diff --git a/src/asm-tests.ss b/src/asm-tests.ss index 7ae6f61..e056ce8 100755 --- a/src/asm-tests.ss +++ b/src/asm-tests.ss @@ -90,7 +90,12 @@ [movl (disp -4 %esp) %eax] [ret])) - +(asm-test 2 + '([movl 12 (disp -8 %esp)] ;;; 12 = 001100 + [movl 24 %eax] ;;; 24 = 011000 + [andl %eax (disp -8 %esp)] + [movl (disp -8 %esp) %eax] + [ret])) (asm-test 3 '([movl 4 (disp -4 %esp)] diff --git a/src/ikarus.boot b/src/ikarus.boot index 5401e6c..9d8be67 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index fa3544c..3dcabe6 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -229,6 +229,14 @@ [$code->closure v] [$closure-code v] + [$make-tcbucket v] + [$tcbucket-key v] + [$tcbucket-val v] + [$tcbucket-next v] + [$set-tcbucket-tconc! e] + [$set-tcbucket-val! e] + [$set-tcbucket-next! e] + [$cpref v] [primitive-set! e] [primitive-ref v] @@ -731,27 +739,18 @@ [(primcall op arg*) (case op [(nop) nop] - [(primitive-set!) - (let ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (mem-assign v x - (- disp-symbol-system-value symbol-tag)))] - [($set-symbol-value!) - (tbind ([x (Value (car arg*))] - [v (Value (cadr arg*))]) - (mem-assign v x - (- disp-symbol-value symbol-tag)))] - [($set-symbol-string!) - (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (mem-assign v x - (- disp-symbol-string symbol-tag)))] - [($set-symbol-unique-string!) - (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (mem-assign v x - (- disp-symbol-unique-string symbol-tag)))] - [($set-symbol-plist!) - (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (mem-assign v x - (- disp-symbol-plist symbol-tag)))] + [(primitive-set! $set-symbol-value! $set-symbol-string! + $set-symbol-unique-string! $set-symbol-plist!) + (let ([off + (case op + [(primitive-set!) disp-symbol-system-value] + [($set-symbol-value!) disp-symbol-value] + [($set-symbol-string!) disp-symbol-string] + [($set-symbol-unique-string!) disp-symbol-unique-string] + [($set-symbol-plist) disp-symbol-plist] + [else (err x)])]) + (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) + (mem-assign v x (- off symbol-tag))))] [($vector-set! $record-set!) (tbind ([x (Value (car arg*))] [v (Value (caddr arg*))]) @@ -829,17 +828,39 @@ (prm 'sll v (K (- 8 fixnum-shift)))))] [($unset-interrupted!) ;;; PCB INTERRUPT (prm 'mset pcr (K 40) (K 0))] - [($set-port-input-index! $set-port-output-index! - $set-port-input-size! $set-port-output-size!) + [($set-port-input-index! $set-port-output-index!) (let ([off (case op - [($set-port-input-index!) disp-port-input-index] - [($set-port-input-size!) disp-port-input-size] - [($set-port-output-index!) disp-port-output-index] - [($set-port-output-size!) disp-port-output-size] + [($set-port-input-index!) disp-port-input-index] + [($set-port-output-index!) disp-port-output-index] [else (err x)])]) - (tbind ([p (Value (car arg*))] + (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))]) - (prm 'mset p (K (- off vector-tag)) v)))] + (prm 'mset x (K (- off vector-tag)) v)))] + [($set-port-input-size! $set-port-output-size!) + (let-values ([(sz-off idx-off) + (case op + [($set-port-input-size!) + (values disp-port-input-size + disp-port-input-index)] + [($set-port-output-size!) + (values disp-port-output-size + disp-port-output-index)] + [else (err x)])]) + (tbind ([x (Value (car arg*))] + [v (Value (cadr arg*))]) + (seq* + (prm 'mset x (K (- idx-off vector-tag)) (K 0)) + (prm 'mset x (K (- sz-off vector-tag)) v))))] + [($set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!) + (tbind ([x (Value (car arg*))] + [v (Value (cadr arg*))]) + (mem-assign v x + (- (case op + [($set-tcbucket-tconc!) disp-tcbucket-tconc] + [($set-tcbucket-next!) disp-tcbucket-next] + [($set-tcbucket-val!) disp-tcbucket-val] + [else (err 'tcbucket!)]) + vector-tag)))] [else (error who "invalid effect prim ~s" op)])] [(forcall op arg*) (make-forcall op (map Value arg*))] @@ -854,12 +875,10 @@ (define (tag-test x mask tag) (tbind ([x x]) (if mask - (make-primcall '= - (list (make-primcall 'logand - (list x (make-constant mask))) - (make-constant tag))) - (make-primcall '= - (list x (make-constant tag)))))) + (prm '= + (prm 'logand x (K mask)) + (K tag)) + (prm '= x (K tag))))) (define (sec-tag-test x pmask ptag smask stag) (tbind ([t x]) (make-conditional @@ -1418,7 +1437,7 @@ (apply (lambda (handler buf/i idx/i sz/i buf/o idx/o sz/o) (tbind ([p (prm 'alloc - (K (align port-size)) + (K (align port-size)) (K vector-tag))]) (seq* (prm 'mset p @@ -1490,6 +1509,37 @@ (K (- disp-code-data vector-tag)))) (K 255)) (K fixnum-shift)))] + [($make-tcbucket) + (tbind ([tconc (Value (car arg*))] + [key (Value (cadr arg*))] + [val (Value (caddr arg*))] + [next (Value (cadddr arg*))]) + (tbind ([x (prm 'alloc + (K (align tcbucket-size)) + (K vector-tag))]) + (seq* + (prm 'mset x + (K (- disp-tcbucket-tconc vector-tag)) + tconc) + (prm 'mset x + (K (- disp-tcbucket-key vector-tag)) + key) + (prm 'mset x + (K (- disp-tcbucket-val vector-tag)) + val) + (prm 'mset x + (K (- disp-tcbucket-next vector-tag)) + next) + x)))] + [($tcbucket-key) + (tbind ([x (Value (car arg*))]) + (prm 'mref x (K (- disp-tcbucket-key vector-tag))))] + [($tcbucket-val) + (tbind ([x (Value (car arg*))]) + (prm 'mref x (K (- disp-tcbucket-val vector-tag))))] + [($tcbucket-next) + (tbind ([x (Value (car arg*))]) + (prm 'mref x (K (- disp-tcbucket-next vector-tag))))] [else (error who "value prim ~a not supported" (unparse x))])] [(forcall op arg*) (make-forcall op (map Value arg*))] diff --git a/src/libchezio.ss b/src/libchezio.ss index 452e512..56e84f0 100644 --- a/src/libchezio.ss +++ b/src/libchezio.ss @@ -90,6 +90,7 @@ ($make-port/both handler input-buffer 0 ($string-length input-buffer) output-buffer 0 ($string-length output-buffer)))) + ;;; (primitive-set! 'make-input/output-port (lambda (handler input-buffer output-buffer) (if (procedure? handler) diff --git a/src/libintelasm.ss b/src/libintelasm.ss index 48b06a9..790a6d8 100644 --- a/src/libintelasm.ss +++ b/src/libintelasm.ss @@ -586,6 +586,8 @@ (CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))] [(and (reg? src) (reg? dst)) (CODE #x21 (ModRM 3 src dst ac))] + [(and (reg? src) (mem? dst)) + ((CODE/digit #x21 src) dst ac)] [(and (mem? src) (reg? dst)) (CODErd #x23 dst src ac)] [else (error who "invalid ~s" instr)])] diff --git a/src/psyntax-7.1.ss b/src/psyntax-7.1.ss index e545652..59106ea 100644 --- a/src/psyntax-7.1.ss +++ b/src/psyntax-7.1.ss @@ -613,6 +613,8 @@ (lambda (symbol) (getprop symbol '*sc-expander*))) + + (define put-global-definition-hook (lambda (symbol x) (if (not x) @@ -777,9 +779,6 @@ (define-syntax build-foreign-call (syntax-rules () [(_ ae name arg*) `(foreign-call ,name . ,arg*)])) -;;;X (define-syntax build-$apply -;;;X (syntax-rules () -;;;X [(_ ae proc arg*) `($apply ,proc . ,arg*)])) (define-syntax build-data (syntax-rules () @@ -801,7 +800,6 @@ body-exp `(letrec ,(map list vars val-exps) ,body-exp)))) - (define build-body (lambda (ae vars val-exps body-exp) (build-letrec ae vars val-exps body-exp))) @@ -1734,7 +1732,8 @@ (let dobody ((body body)) (if (null? body) '() - (let ((first (chi-top (car body) r w ctem rtem meta? ribcage meta-residualize! #f))) + (let ((first (chi-top (car body) r w ctem rtem meta? ribcage + meta-residualize! #f))) (cons first (dobody (cdr body))))))))) (define chi-top