inline-data.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000, 2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      inline-data.lisp
   7 ;;;; Description:   Objects that represents inline data in assembly listings.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Mon Aug 21 10:35:46 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: inline-data.lisp,v 1.3 2004/02/10 00:03:30 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package #:ia-x86)
  17
  18 (defclass inline-data () ())
  19
  20 (defun bitsize-to-sizeof (bitsize)
  21   (unless (and (>= bitsize 0)
  22                (zerop (mod bitsize 8)))
  23     (error "Illegal bitsize ~A, must be positive multiple of 8." bitsize))
  24   (truncate bitsize 8))
  25
  26 (defclass inline-data-format (inline-data)
  27   ((format :reader inline-data-format-format
  28            :initarg  format)
  29    (sizeof :reader inline-data-format-sizeof
  30            :initarg sizeof)
  31    (args   :reader inline-data-format-args
  32            :initarg args)))
  33
  34 (defun make-inline-data-format (bitsize format args)
  35   "Make an inlined, formatted, null-terminated string."
  36   (check-type format string)
  37   (make-instance 'inline-data-format
  38     'format format
  39     'sizeof (and bitsize (bitsize-to-sizeof bitsize))
  40     'args args))
  41
  42 (defmethod inline-data-encode ((data inline-data-format) env)
  43   (with-slots (format sizeof args) data
  44     (let ((string (apply #'format nil format (inline-data-resolve-arglist args env))))
  45       (when (and sizeof (plusp sizeof)
  46                  (>= (length string) (expt 2 (* 8 sizeof))))
  47         (error "String doesn't fit in ~D-byte: ~S" (* 8 sizeof) format))
  48       (nconc
  49        ;; if we have a positive sizeof, insert byte with string-length.
  50        (if (and sizeof (plusp sizeof))
  51            (list (complex (length string) sizeof))
  52          nil)
  53        ;; insert the string
  54        (map 'list #'(lambda (c) (complex (char-code c) 1)) string)
  55        ;; if sizeof is zero, null-terminate the string.
  56        (and sizeof (zerop sizeof) (list #c(0 1)))))))
  57
  58 (defmethod inline-data-guess-sizeof ((data inline-data-format) env)
  59   (with-slots (format sizeof args) data
  60     (+ (or (and sizeof (zerop sizeof) 1) 0)
  61        (length (apply #'format nil format (inline-data-resolve-arglist-with-zeros args env))))))
  62
  63 (defmethod print-object ((obj inline-data-format) stream)
  64   (cond
  65    (*print-pretty*
  66     (format stream
  67             "#<asm string ~S>"
  68             (inline-data-format-format obj))
  69     obj)
  70    (t (call-next-method obj stream))))
  71
  72 ;;;; Inline data generated assembly-time by functions.
  73
  74 (defclass inline-data-fun (inline-data)
  75   ((fun    :reader inline-data-fun-fun
  76            :initarg fun)
  77    (args   :reader inline-data-fun-args
  78            :initarg args)))
  79
  80 (defun make-inline-fun (expr)
  81   (destructuring-bind ((fun &rest args)) expr
  82     (make-instance 'inline-data-fun
  83       'fun fun
  84       'args args)))
  85
  86 (defmethod inline-data-guess-sizeof ((data inline-data-fun) env)
  87   (loop for cbyte in (apply (inline-data-fun-fun data)
  88                             (inline-data-resolve-arglist-with-zeros (inline-data-fun-args data) env))
  89       summing (imagpart cbyte)))
  90
  91 (defmethod inline-data-encode ((data inline-data-fun) env)
  92   (mapcar #'(lambda (cbyte)
  93               (complex (change-endian (realpart cbyte) (imagpart cbyte))
  94                        (imagpart cbyte)))
  95           (apply (inline-data-fun-fun data)
  96                  (inline-data-resolve-arglist (inline-data-fun-args data) env))))
  97
  98 ;;;; Inline bytes (of various sizes)
  99
 100 (defclass inline-bytes (inline-data)
 101   ((values :reader inline-bytes-values
 102            :initarg values)
 103    (sizeof :reader inline-bytes-sizeof
 104            :initarg sizeof)))
 105
 106 (defmethod inline-data-guess-sizeof ((data inline-bytes) env)
 107   (declare (ignore env))
 108   (* (length (inline-bytes-values data))
 109      (inline-bytes-sizeof data)))
 110
 111 (defmethod inline-data-encode ((data inline-bytes) env)
 112   (mapcar #'(lambda (value)
 113               (complex (change-endian value (inline-bytes-sizeof data))
 114                        (inline-bytes-sizeof data)))
 115           (inline-data-resolve-arglist (inline-bytes-values data) env)))
 116
 117 (defun make-inline-bytes (sizeof args)
 118   (unless (and (plusp sizeof)
 119                (zerop (mod sizeof 8)))
 120     (error "Illegal byte-size ~A, must be positive multiple of 8." sizeof))
 121   (make-instance 'inline-bytes
 122     'values args
 123     'sizeof (truncate sizeof 8)))
 124
 125 ;;; Inline aligment
 126
 127 (defclass inline-alignment (inline-data)
 128   ((align :reader inline-alignment-align
 129           :initarg align)
 130    (fill-octet :reader inline-alignment-fill-octet
 131                :initarg fill-octet)))
 132
 133 (defun make-inline-alignment (align &optional (fill-octet 0))
 134   (check-type fill-octet (unsigned-byte 8))
 135   (make-instance 'inline-alignment
 136     'align align
 137     'fill-octet fill-octet))
 138
 139 (defmethod inline-data-encode ((data inline-alignment) env)
 140   (loop for i from 0
 141       while (not (zerop (mod (+ i (assemble-env-current-pc env))
 142                              (inline-alignment-align data))))
 143       collect (complex (inline-alignment-fill-octet data) 1)))
 144
 145
 146 ;;;; label resolver functions
 147
 148 (defun inline-data-label-reference-p (expr)
 149   "Determine if EXPR is a label refenence (i.e. a quoted symbol)."
 150   (and (listp expr)
 151        (= 2 (length expr))
 152        (eq 'quote (first expr))
 153        (symbolp (second expr))))
 154
 155 (defun inline-data-resolve-arglist (arglist env)
 156   (let* (unresolveds
 157          (arglist (mapcar #'(lambda (arg)
 158                               (if (inline-data-label-reference-p arg)
 159                                   (or (symtab-try-lookup-label (assemble-env-symtab env) (second arg))
 160                                       (pushnew (second arg) unresolveds))
 161                                 arg))
 162                           arglist)))
 163     (if (not (null unresolveds))
 164         (error 'unresolved-labels 'labels unresolveds)
 165       arglist)))
 166
 167 (defun inline-data-resolve-arglist-with-zeros (arglist env)
 168   (mapcar #'(lambda (arg)
 169               (if (inline-data-label-reference-p arg)
 170                   (or (symtab-try-lookup-label (assemble-env-symtab env) (second arg))
 171                       0)
 172                 arg))
 173           arglist))
 174
 175
 176 (defun read-inline-data (expr)
 177   (destructuring-bind (marker type &rest args)
 178       expr
 179     (assert (string= '% marker))
 180     (cond
 181      ((string= 'format type) (make-inline-data-format (first args) (second args) (nthcdr 2 args)))
 182      ((string= 'fun type) (make-inline-fun args))
 183      ((string= 'bytes type) (make-inline-bytes (first args) (rest args)))
 184      ((string= 'align type) (apply #'make-inline-alignment args))
 185      (t (error "Unknown inline data item: ~A" expr)))))