module: dfmc-modeling author: jonathan bachrach Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. All rights reserved. License: Functional Objects Library Public License Version 1.0 Dual-license: GNU Lesser General Public License Warranty: Distributed WITHOUT WARRANTY OF ANY KIND define custom &machine-word-primitive primitive-integer? (x :: ) => (result :: ) make-raw-literal(instance?(x, )) end; define sign-extend &machine-word-primitive primitive-machine-word-equal? (x :: , y :: ) => (result :: ) x = y end; define sign-extend &machine-word-primitive primitive-machine-word-not-equal? (x :: , y :: ) => (result :: ) x ~= y end; define sign-extend &machine-word-primitive primitive-machine-word-less-than? (x :: , y :: ) => (result :: ) x < y end; define sign-extend &machine-word-primitive primitive-machine-word-not-less-than? (x :: , y :: ) => (result :: ) x >= y end; define sign-extend &machine-word-primitive primitive-machine-word-greater-than? (x :: , y :: ) => (result :: ) x > y end; define sign-extend &machine-word-primitive primitive-machine-word-not-greater-than? (x :: , y :: ) => (result :: ) x <= y end; define custom &machine-word-primitive primitive-wrap-machine-word (x :: ) => (result :: ) // TODO: CORRECTNESS: This gets iep's when compiling C-callables. Why? select (x by instance?) <&raw-integer> => make(<&machine-word>, data: make(<&raw-machine-word>, value: ^raw-object-value(x))); <&raw-byte-character> => make(<&machine-word>, data: make(<&raw-machine-word>, value: as(, ^raw-object-value(x)))); <&raw-machine-word> => let raw-value = ^raw-object-value(x); if (instance?(raw-value, <&machine-word>)) raw-value else make(<&machine-word>, data: make(<&raw-machine-word>, value: raw-value)) end; end end; define custom &machine-word-primitive primitive-unwrap-machine-word (x :: ) => (result :: ) select (x by instance?) => make-raw-literal(x); => make-raw-literal(as(, x)); <&machine-word> => ^%machine-word-data(x); otherwise => error("PUNT THIS FOLDER"); end end; /// NOTE: Not used with our current representation define &simple-machine-word-primitive primitive-box-integer (x :: ) => (result :: ); /// NOTE: Not used with our current representation define &simple-machine-word-primitive primitive-unbox-integer (x :: ) => (result :: ); /// NOTE: The folder for this primitive contains intimate knowledge of the representation /// of s and will have to be updated if we ever change representations. Also, /// it can't fold all s values as the call to ash will signal overflow under /// some conditions. (Sigh) define custom &machine-word-primitive primitive-cast-integer-as-raw (x :: ) => (result :: ) make-raw-literal(generic/logior(generic/ash(x, 2), 1)) end; /// NOTE: The folder for this primitive contains intimate knowledge of the representation /// of s and will have to be updated if we ever change representations. define custom &machine-word-primitive primitive-cast-raw-as-integer (x :: ) => (result :: ) // Signals an error if the result is too big to be an ... let x :: = extract-mw-operand-unsigned(x); as(, generic/lsh(x, -2)) end; define custom &machine-word-primitive primitive-wrap-abstract-integer (x :: ) => (result :: ) ^raw-object-value(x) end; define &simple-machine-word-primitive primitive-wrap-unsigned-abstract-integer (x :: ) => (result :: ); define custom &machine-word-primitive primitive-unwrap-abstract-integer (x :: ) => (result :: ) make-raw-literal(x) end; define &simple-machine-word-primitive primitive-machine-word-boole (s :: , x :: , y :: ) => (result :: ); define &machine-word-primitive primitive-machine-word-logand (x :: , y :: ) => (result :: ) generic/logand(x, y) end; define &machine-word-primitive primitive-machine-word-logior (x :: , y :: ) => (result :: ) generic/logior(x, y) end; define &machine-word-primitive primitive-machine-word-logxor (x :: , y :: ) => (result :: ) generic/logxor(x, y) end; define &machine-word-primitive primitive-machine-word-lognot (x :: ) => (result :: ) generic/lognot(x) end; define &machine-word-primitive primitive-machine-word-logbit? (index :: , y :: ) => (result :: ) generic/logbit?(index, y) end; /// TODO: THESE ARE ACTUALLY IN DYLAN LIBRARY define inline function logbit-set (index :: , y :: ) => (r :: ) generic/logior(y, generic/ash(1, index)) end function; define inline function logbit-clear (index :: , y :: ) => (r :: ) generic/logand(y, generic/lognot(generic/ash(1, index))) end function; define &machine-word-primitive primitive-machine-word-logbit-set (index :: , y :: ) => (result :: ) logbit-set(index, y) end; define &machine-word-primitive primitive-machine-word-logbit-clear (index :: , y :: ) => (result :: ) logbit-clear(index, y) end; /// TODO: THESE ARE ACTUALLY IN DYLAN LIBRARY define inline function bit-field-extract (offset :: , size :: , x :: ) => (res :: ) generic/ash(generic/logand(x, generic/ash(generic/-(generic/ash(1, size), 1), offset)), generic/negative(offset)) end function bit-field-extract; define inline function bit-field-deposit (field :: , offset :: , size :: , x :: ) => (res :: ) generic/logior(generic/logand(x, generic/lognot(generic/ash(generic/-(generic/ash(1, size), 1), offset))), generic/ash(field, offset)) end function bit-field-deposit; define &machine-word-primitive primitive-machine-word-bit-field-deposit (field :: , offset :: , size :: , x :: ) => (result :: ) bit-field-deposit(field, offset, size, x) end; define &machine-word-primitive primitive-machine-word-bit-field-extract (offset :: , size :: , x :: ) => (result :: ) bit-field-extract(offset, size, x) end; define &simple-machine-word-primitive primitive-machine-word-count-low-zeros (x :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-count-high-zeros (x :: ) => (result :: ); define &machine-word-primitive primitive-machine-word-add (x :: , y :: ) => (sum :: ) generic/+(x, y) end; define &simple-machine-word-primitive primitive-machine-word-add-with-overflow (x :: , y :: ) => (sum :: , overflow? :: ); define &machine-word-primitive primitive-machine-word-subtract (x :: , y :: ) => (difference :: ) generic/-(x, y) end; define &simple-machine-word-primitive primitive-machine-word-subtract-with-overflow (x :: , y :: ) => (difference :: , overflow? :: ); define &machine-word-primitive primitive-machine-word-multiply-low (x :: , y :: )=> (low :: ) generic/*(x, y) end; define &simple-machine-word-primitive primitive-machine-word-multiply-high (x :: , y :: ) => (high :: ); define &simple-machine-word-primitive primitive-machine-word-multiply-low/high (x :: , y :: ) => (low :: , high :: ); define &simple-machine-word-primitive primitive-machine-word-multiply-low-with-overflow (x :: , y :: ) => (low :: , overflow? :: ); define &simple-machine-word-primitive primitive-machine-word-multiply-with-overflow (x :: , y :: ) => (low :: , high :: , overflow? :: ); define sign-extend &machine-word-primitive primitive-machine-word-negative (x :: ) => (result :: ) generic/negative(x) end; define &simple-machine-word-primitive primitive-machine-word-negative-with-overflow (x :: ) => (result :: , overflow? :: ); define sign-extend &machine-word-primitive primitive-machine-word-abs (x :: ) => (result :: ) generic/abs(x) end; define &simple-machine-word-primitive primitive-machine-word-abs-with-overflow (x :: ) => (result :: , overflow? :: ); define &machine-word-primitive primitive-machine-word-floor/-quotient (dividend :: , divisor :: ) => (quotient :: ) generic/floor/(dividend, divisor) end; define &machine-word-primitive primitive-machine-word-floor/-remainder (dividend :: , divisor :: ) => (remainder :: ) let (quotient, remainder) = generic/floor/(dividend, divisor); remainder end; define &simple-machine-word-primitive primitive-machine-word-floor/ (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define &machine-word-primitive primitive-machine-word-ceiling/-quotient (dividend :: , divisor :: ) => (quotient :: ) generic/ceiling/(dividend, divisor) end; define &machine-word-primitive primitive-machine-word-ceiling/-remainder (dividend :: , divisor :: ) => (remainder :: ) let (quotient, remainder) = generic/ceiling/(dividend, divisor); remainder; end; define &simple-machine-word-primitive primitive-machine-word-ceiling/ (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define &machine-word-primitive primitive-machine-word-round/-quotient (dividend :: , divisor :: ) => (quotient :: ) generic/round/(dividend, divisor) end; define &machine-word-primitive primitive-machine-word-round/-remainder (dividend :: , divisor :: ) => (remainder :: ) let (quotient, remainder) = generic/round/(dividend, divisor); remainder end; define &simple-machine-word-primitive primitive-machine-word-round/ (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define &machine-word-primitive primitive-machine-word-truncate/-quotient (dividend :: , divisor :: ) => (quotient :: ) generic/truncate/(dividend, divisor) end; define &machine-word-primitive primitive-machine-word-truncate/-remainder (dividend :: , divisor :: ) => (remainder :: ) let (quotient, remainder) = generic/truncate/(dividend, divisor); remainder end; define &simple-machine-word-primitive primitive-machine-word-truncate/ (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-divide-quotient (dividend :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-divide-remainder (dividend :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-divide (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define sign-extend &machine-word-primitive primitive-machine-word-shift-left-low (x :: , shift :: ) => (low :: ) generic/ash(x, shift) end; define &simple-machine-word-primitive primitive-machine-word-shift-left-high (x :: , shift :: ) => (high :: ); define &simple-machine-word-primitive primitive-machine-word-shift-left-low/high (x :: , shift :: ) => (low :: , high :: ); define &simple-machine-word-primitive primitive-machine-word-shift-left-low-with-overflow (x :: , shift :: ) => (low :: , overflow? :: ); define &simple-machine-word-primitive primitive-machine-word-shift-left-with-overflow (x :: , shift :: ) => (low :: , high :: , overflow? :: ); define sign-extend &machine-word-primitive primitive-machine-word-shift-right (x :: , shift :: ) => (result :: ) generic/ash(x, generic/negative(shift)) end; /// NOTE: We can still try to fold the overflow signalling primtives because, if the /// computation overflows at compile time, the folding will be abandoned, the primitive /// will be called at run-time, and the overflow will be signalled. define overflow &machine-word-primitive primitive-machine-word-add-signal-overflow (x :: , y :: ) => (sum :: ) generic/+(x, y) end; define overflow &machine-word-primitive primitive-machine-word-subtract-signal-overflow (x :: , y :: ) => (difference :: ) generic/-(x, y) end; define overflow &machine-word-primitive primitive-machine-word-multiply-signal-overflow (x :: , y :: ) => (low :: ) generic/*(x, y) end; define sign-extend overflow &machine-word-primitive primitive-machine-word-negative-signal-overflow (x :: ) => (result :: ) generic/negative(x) end; define sign-extend overflow &machine-word-primitive primitive-machine-word-abs-signal-overflow (x :: ) => (result :: ) generic/abs(x) end; define sign-extend overflow &machine-word-primitive primitive-machine-word-shift-left-signal-overflow (x :: , shift :: ) => (result :: ) generic/ash(x, shift) end; define &simple-machine-word-primitive primitive-machine-word-double-floor/-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-double-floor/-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-floor/ (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-ceiling/-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-double-ceiling/-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-ceiling/ (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-round/-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-double-round/-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-round/ (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-truncate/-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-double-truncate/-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-truncate/ (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-divide-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-double-divide-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-double-divide (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &machine-word-primitive primitive-machine-word-unsigned-less-than? (x :: , y :: ) => (result :: ) x < y end; define &machine-word-primitive primitive-machine-word-unsigned-not-less-than? (x :: , y :: ) => (result :: ) x >= y end; define &machine-word-primitive primitive-machine-word-unsigned-greater-than? (x :: , y :: ) => (result :: ) x > y end; define &machine-word-primitive primitive-machine-word-unsigned-not-greater-than? (x :: , y :: ) => (result :: ) x <= y end; define &simple-machine-word-primitive primitive-machine-word-unsigned-add-with-carry (x :: , y :: ) => (sum :: , carry :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-subtract-with-borrow (x :: , y :: ) => (difference :: , borrow :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-multiply-high (x :: , y :: ) => (high :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-multiply (x :: , y :: ) => (low :: , high :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-divide-quotient (dividend :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-divide-remainder (dividend :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-divide (dividend :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-rotate-left (x :: , shift :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-rotate-right (x :: , shift :: ) => (result :: ); define &machine-word-primitive primitive-machine-word-unsigned-shift-right (x :: , shift :: ) => (result :: ) generic/lsh(x, generic/negative(shift)) end; define &simple-machine-word-primitive primitive-machine-word-unsigned-double-divide-quotient (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-divide-remainder (dividend-low :: , dividend-high :: , divisor :: ) => (remainder :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-divide (dividend-low :: , dividend-high :: , divisor :: ) => (quotient :: , remainder :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-shift-left-high (x :: , shift :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-shift-left-high (x-low :: , x-high :: , shift :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-shift-left (x-low :: , x-high :: , shift :: ) => (low :: , high :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-shift-right-low (x-low :: , x-high :: , shift :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-shift-right-high (x-low :: , x-high :: , shift :: ) => (result :: ); define &simple-machine-word-primitive primitive-machine-word-unsigned-double-shift-right (x-low :: , x-high :: , shift :: ) => (low :: , high :: ); // eof