home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / backend / interface-codegen.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  15.6 KB  |  454 lines  |  [TEXT/CCL2]
  1. ;;; This generates code for vars defined in an interface.  This looks at
  2. ;;; annotations and fills in the slots of the var definition.
  3.  
  4. ;;; This is all rather crufty.  Here are some of the issues:
  5. ;;;  There is a lot of crud in the Haskell type system that needs fiddling:
  6. ;;;  The IO monad should be removed - this really just indicates to
  7. ;;;   Haskell that the global state is being used.  Thus a signature of
  8. ;;;    Int -> IO Float
  9. ;;;   is really Int -> Float at the Lisp / C level.  There is also a dummy
  10. ;;;   system state argument to be removed too.
  11. ;;;  Lists of chars and Strings are two different data types in Lisp.  For
  12. ;;;   the automatic conversion, the types String and [Char] are treated
  13. ;;;   differently!!!
  14. ;;;  Type synonyms are NOT expanded - we use synonyms to define Lisp / C
  15. ;;;   datatypes which may be ambiguous or unavailable at the Haskell level.
  16. ;;;   For example, a int and an unsigned are both just Integer in Haskell
  17. ;;;   but synonyms indicate what sort of conversion is used across the
  18. ;;;   interface.
  19.  
  20. (define (haskell-codegen/interface mods)
  21.   (let ((functions  '())
  22.     (predefines '())
  23.     (inits      '())
  24.     (has-foreigns? '#f)
  25.     (has-non-foreigns? '#f))
  26.     (dolist (m mods)
  27.       (when (or (module-alg-defs m) (module-synonym-defs m)
  28.         (module-class-defs m) (module-synonym-defs m))
  29.         (setf has-non-foreigns? '#t))
  30.       (dolist (d (module-decls m))
  31.     (when (not (signdecl? d))
  32.       (error "Bad decl in interface file: ~s" d))
  33.     (dolist (v (signdecl-vars d))
  34.       (multiple-value-bind (fn predefine init)
  35.           (codegen/interface (var-ref-var v))
  36.         (when (or (memq 'codegen (dynamic *printers*))
  37.               (memq 'codegen-flic (dynamic *printers*)))
  38.           (when fn (pprint* fn))
  39.           (when init (pprint* init)))
  40.         (if (or fn predefine init)
  41.         (setf has-foreigns? '#t)
  42.         (setf has-non-foreigns? '#t))
  43.         (when fn (push fn functions))
  44.         (when predefine (push predefine predefines))
  45.         (when init (push init inits))))))
  46.     (when (and has-foreigns? has-non-foreigns?)
  47.       (phase-error 'mixed-interface
  48.          "Foreign interface module contains non-foreign definitions"))
  49.     (when has-foreigns?
  50.       (dolist (m mods)
  51.     ;; Definitions in a stand alone module never need forwarding
  52.     ;; or checking against implementations
  53.     (setf (module-interface-definitions m) '()) 
  54.     (setf (module-stand-alone? m) '#t)))
  55.     `(begin ,@(nreverse predefines)
  56.         ,@(nreverse functions)
  57.         ,@(codegen-initcode (nreverse inits)))))
  58.  
  59.  
  60. ;;; Loop over all signature declarations in the interface.  Staple the
  61. ;;; types to the variables.  The following annotations are processed:
  62. ;;;  Complexity - attached to var
  63. ;;;  LispName - attached to van & wrapper generated
  64. ;;;  CName - attached to van & wrapper generated
  65.  
  66. (define (codegen/interface v)
  67.   (let ((a  '#f))
  68.     (setf (var-type v) (var-signature v))
  69.     (setf (var-toplevel? v) '#t)
  70.     (when (setf a (lookup-annotation v '|Complexity|))
  71.       (setf (var-complexity v)
  72.         (car (annotation-value-args a))))
  73.     (cond ((setf a (lookup-annotation v '|LispName|))
  74.        (generate-lisp-entry v a))
  75.       ((setf a (lookup-annotation v '|CName|))
  76.        (generate-c-entry v a))
  77.       (else
  78.        (values '#f '#f '#f))
  79.       )))
  80.  
  81.  
  82. ;;; This generates a wrapper for a Lisp functions.  The wrapper function
  83. ;;; does the following:
  84. ;;;   Converts a fixed library of datatypes between Lisp & Haskell
  85. ;;;   representations
  86. ;;;   Adds the dummy arguemnt to the monad.  Since IO a = 
  87. ;;;      SystemState_ -> IOResult_ a an argument will be passed for SystemState;
  88. ;;;      this is ignored.
  89.  
  90. (define (generate-lisp-entry v a)
  91.   (mlet ((lisp-name (read-lisp-object (car (annotation-value-args a))))
  92.      ((args res io?) (massage-haskell-type (gtype-type (var-type v)))))
  93.     (setf (var-optimized-entry v) lisp-name)
  94.     (if (and (null? args) (not io?))
  95.     (codegen-lisp-const v res)
  96.     (codegen-lisp-fn v args res io?))))
  97.  
  98.  
  99. ;;; When the name does not have a functional or IO type, it is a simple
  100. ;;; constant.  It is always assumed to be non-strict.  A conversion is
  101. ;;; inserted if necessary.  (Bug: this doesn't look at the NoConversion flag).
  102.  
  103. (define (codegen-lisp-const var type)
  104.   (let ((lisp-conversion-fn (output-lisp-conversion-fn type))
  105.     (lispname           (var-optimized-entry var)))
  106.     (when (not (bound? lispname))
  107.       (signal-undefined-lisp-variable lispname))
  108.     (setf (var-strict? var) '#f)
  109.     (setf (var-arity var) 0)
  110.     (setf (var-strictness var) '())
  111.     (values
  112.       '#f
  113.       `(define ,(fullname var) '#f)
  114.       `(setf ,(fullname var)
  115.              (delay
  116.            ,(apply-conversion lisp-conversion-fn lispname))))
  117.     ))
  118.  
  119. ;;; This generates the Haskell level wrapper for a function and
  120. ;;; sets up Haskell level attributes.
  121.  
  122. (define (codegen-foreign-function var strictness fn-code)
  123.   (setf (var-strict? var) '#t)
  124.   (setf (var-arity var) (length strictness))
  125.   (setf (var-strictness var) strictness)
  126.   `(setf ,(fullname var)
  127.      ,(maybe-make-box-value
  128.        (codegen-curried-fn fn-code strictness)
  129.        '#t)))
  130.  
  131. (define (codegen-lisp-fn var arg-types res-type io?)
  132.   (let* ((wrapper?  (foreign-fn-needs-wrapper? var arg-types res-type io?))
  133.      (strictness-ann (lookup-annotation var '|Strictness|))
  134.      (strictness (determine-strictness strictness-ann arg-types io?))
  135.      (lispname   (var-optimized-entry var))) 
  136.     (when (not (fbound? lispname))
  137.       (signal-undefined-lisp-function lispname))
  138.     ;; The optimized-entry slot contains the lisp function name - when a
  139.     ;; wrapper is added this is moved into the wrapper and the optimized
  140.     ;; entry receives the wrapper function name.
  141.     (if wrapper?
  142.     (multiple-value-bind (wrapper-code name)
  143.         (make-wrapper-fn var lispname arg-types res-type io?)
  144.       (setf (var-optimized-entry var) name)
  145.       (values
  146.         wrapper-code
  147.         `(define ,(fullname var) '#f)
  148.         (codegen-foreign-function
  149.           var strictness `(function ,name))))
  150.     ;; Since the definition may be a macro of some sort wrap a
  151.     ;; lambda around the function name.
  152.     (values
  153.       '#f
  154.       `(define ,(fullname var) '#f)
  155.       (codegen-foreign-function
  156.           var
  157.         strictness
  158.         (if (syntax? lispname)
  159.         (let ((temps (gen-temp-names strictness)))
  160.           `(lambda ,temps (,lispname ,@temps)))
  161.           `(function ,lispname))))
  162.     )))
  163.  
  164.  
  165. (define (signal-undefined-lisp-variable name)
  166.   (haskell-warning 'undefined-lisp-variable
  167.            "Undefined Lisp variable ~s in interface." name))
  168.  
  169. (define (signal-undefined-lisp-function name)
  170.   (haskell-warning 'undefined-lisp-function
  171.            "Undefined Lisp function ~s in interface." name))
  172.  
  173.  
  174.  
  175.  
  176. ;;; This computes the strictness of an imported Lisp / C function.  If the
  177. ;;; strictness is explicitly provided use this (not available for C
  178. ;;; functions) otherwise make every argument strict.  If the IO monad is
  179. ;;; referenced, make the hidden system state parameter nonstrict.
  180.  
  181. (define (determine-strictness a args io?)
  182.   (let ((s (if (eq? a '#f)
  183.            (map (lambda (x) (declare (ignore x)) '#t) args)
  184.            (parse-strictness (car (annotation-value-args a))))))
  185.     ;; IO functions have a hidden extra argument that is always
  186.     ;; nonstrict.
  187.         (if io? (append s '(#f)) s)))
  188.  
  189.  
  190. ;;; This processes a Haskell type and delivers:
  191. ;;;   argument types
  192. ;;;   result type
  193. ;;;   flag to indicate whether the IO monad is being used
  194. ;;;  In general, type synonyms are not expanded.   Synonyms which expand 
  195. ;;;  to arrow types (other than Dialogue) DON'T WORK!!
  196.  
  197. (define (massage-haskell-type ty)
  198.   (cond ((arrow-type? ty)
  199.      (multiple-value-bind (args res io?)
  200.          (massage-haskell-type (cadr (ntycon-args ty)))
  201.        (values (cons (car (ntycon-args ty)) args) res io?)))
  202.     ((ntycon? ty)
  203.      (let ((tycon (ntycon-tycon ty)))
  204.        (cond ((eq? tycon (core-symbol "IO"))
  205.           (values '() (car (ntycon-args ty)) '#t))
  206.          (else (values '() ty '#f)))))
  207.     (else (values '() ty '#f))))
  208.  
  209. ;;; This generates a Lisp input conversion function (represented by a function
  210. ;;; which is applied to the code which evaluates to the argument; no conversion
  211. ;;; would be the identity function but we use #f instead so that we can easily
  212. ;;; detect arguments with no conversion and avoid an assignment).
  213.  
  214. ;;; Numerics and Booleans do not need conversion since these have the same
  215. ;;; representation in Lisp and Haskell.  Characters, strings, and lists
  216. ;;; are converted.  Note that type String is converted to a Lisp string
  217. ;;; while [Char] would be converted to a list of characters.  Also, the
  218. ;;; list conversion recursively converts the inner type.
  219.  
  220. ;;; Characters are represented as integers in Haskell; integer->char makes
  221. ;;; the Lisp characters.
  222.  
  223. ;;; Both strings & lists are strictified.
  224.  
  225. (define (input-lisp-conversion-fn ty)
  226.   (if (ntycon? ty)
  227.       (let ((tycon (ntycon-tycon ty)))
  228.     (cond ((eq? tycon (core-symbol "String"))
  229.            (lambda (x) `(haskell-string->string ,x)))
  230.           ((eq? tycon (core-symbol "List"))  ; needs to convert elements
  231.            (let ((var (gensym "X"))
  232.              (inner-fn (input-lisp-conversion-fn (car (ntycon-args ty)))))
  233.          (lambda (x) `(haskell-list->list
  234.                    (lambda (,var)
  235.                  ,(if (eq? inner-fn '#f)
  236.                       var
  237.                       (funcall inner-fn var)))
  238.                    ,x))))
  239.           ((eq? tycon (core-symbol "Char"))
  240.            (lambda (x) `(integer->char ,x)))
  241.           (else '#f)))
  242.       '#f))
  243.  
  244. ;;; This is similar to the input conversion function except that a
  245. ;;; couple of extra special cases exist.
  246.  
  247. ;;;  When the output is of the unit type, the actual value returned by
  248. ;;;  the Lisp function is ignored and the unit is generated directly.
  249.  
  250. (define (output-lisp-conversion-fn ty)
  251.   (if (ntycon? ty)
  252.       (let ((tycon (ntycon-tycon ty)))
  253.     (cond ((eq? tycon (core-symbol "String"))
  254.            (lambda (x) `(make-haskell-string ,x)))
  255.           ((eq? tycon (core-symbol "List"))
  256.            (let ((var (gensym "X"))
  257.              (inner-fn (output-lisp-conversion-fn
  258.                 (car (ntycon-args ty)))))
  259.          (lambda (x) `(list->haskell-list
  260.                    (lambda (,var)
  261.                  ,(if (eq? inner-fn '#f)
  262.                       var
  263.                       (funcall inner-fn var)))
  264.                    ,x))))
  265.           ;; For the unit type we need to evaluate the value - insert
  266.           ;; unit type evaluates its arg and returns the unit.
  267.           ((eq? tycon (core-symbol "UnitType"))
  268.            (lambda (x) `(insert-unit-value ,x)))
  269.           ((eq? tycon (core-symbol "Char"))
  270.            (lambda (x) `(char->integer ,x)))
  271.           (else '#f)))
  272.       '#f))
  273.  
  274. ;;; This makes #f behave as the identity function for value conversion.
  275.  
  276. (define (apply-conversion fn x)
  277.   (if (eq? fn '#f)
  278.       x
  279.       (funcall fn x)))
  280.  
  281. ;;; This determines whether a foreign function actually needs a wrapper
  282. ;;; (This wrapper is distinct from the standard Haskell wrapper used for
  283. ;;; uncurrying and strictness optimizations).  When no conversions are
  284. ;;; needed or the NoConversion annotation is present the wrapper is
  285. ;;; omitted.
  286.  
  287. (define (foreign-fn-needs-wrapper? var args res io?)
  288.  (cond ((lookup-annotation var '|NoConversion|)  '#f)
  289.        (io?                                      '#t)
  290.        ((output-lisp-conversion-fn res)               '#t)
  291.        (else (some (lambda (x) (input-lisp-conversion-fn x)) args))))
  292.  
  293. ;;; This creates the code for the wrapper.
  294.  
  295. (define (make-wrapper-fn var fn arg-types res-type io?)
  296.   (let* ((new-fn (symbol-append (fullname var) '|/wrapper|))
  297.      (avars (gen-temp-names arg-types))
  298.      (arg-conversions (collect-conversion-fns
  299.                (function input-lisp-conversion-fn)
  300.                avars arg-types))
  301.      (res-conversion (output-lisp-conversion-fn res-type))
  302.      (fn-call (apply-conversion res-conversion `(,fn ,@avars))))
  303.      (values
  304.       (if io?
  305.       `(define (,new-fn ,@avars ignored-state)
  306.          (declare (ignore ignored-state))
  307.          ,@arg-conversions
  308.          (io-return ,fn-call))
  309.       `(define (,new-fn ,@avars)
  310.          ,@arg-conversions
  311.          ,fn-call))
  312.       new-fn)))
  313.  
  314. ;;; This converts incoming values by generating a setf for each arg
  315. ;;; needing conversion.
  316.  
  317. (define (collect-conversion-fns fn avars arg-types)
  318.   (if (null? arg-types)
  319.       '()
  320.       (let ((cfn (funcall fn (car arg-types)))
  321.         (rest (collect-conversion-fns fn (cdr avars) (cdr arg-types))))
  322.     (if cfn
  323.         `((setf ,(car avars) ,(funcall cfn (car avars))) ,@rest)
  324.         rest))))
  325.  
  326. ;;; Some random utilities
  327.  
  328. (define (arrow-type? x)
  329.   (and (ntycon? x)
  330.        (eq? (ntycon-tycon x) (core-symbol "Arrow"))))
  331.  
  332. (define (systemstate? x)
  333.   (and (ntycon? x)
  334.        (eq? (ntycon-tycon x) (core-symbol "SystemState_"))))
  335.  
  336.  
  337. ;;; Stuff to support the C interface
  338.  
  339. (define (generate-c-entry v a)
  340.   (mlet ((c-name (car (annotation-value-args a)))
  341.      ((args res io?) (massage-haskell-type (gtype-type (var-type v)))))
  342.     (if (and (null? args) (not io?))
  343.     ;; I'm too lazy to write the interface to C constants
  344.     (phase-error 'c-routine-error "Not a function type: ~A" v)
  345.     (codegen-c-fn v c-name args res io?))))
  346.  
  347. ;;; Every C function generates a C type template, a Lisp wrapper, and a Haskell
  348. ;;; wrapper.
  349.  
  350. (define (codegen-c-fn var c-name arg-types res-type io?)
  351.   (let* ((strictness (determine-strictness '#f arg-types io?))
  352.      (c-types (map (function convert-to-c-type) arg-types))
  353.      (c-res-type (convert-to-c-type res-type)))
  354.     (multiple-value-bind (code c-type-def name)
  355.     (make-c-wrapper-fn var c-name c-types c-res-type io?)
  356.       (setf (var-optimized-entry var) name)
  357.       (values
  358.         `(begin ,code ,c-type-def )
  359.     `(define ,(fullname var) '#f)
  360.     (codegen-foreign-function var strictness
  361.                   `(function ,(var-optimized-entry var)))))))
  362.  
  363. ;;; This generates a C -> Lisp wrapper.
  364.  
  365. (define (make-c-wrapper-fn var c-name arg-types res-type io?)
  366.   (mlet ((new-fn (symbol-append (fullname var) '|/wrapper|))
  367.      (new-lisp-fn (symbol-append (fullname var) '|/c-entry|))
  368.      (avars (gen-temp-names arg-types))
  369.      (arg-conversions (collect-conversion-fns
  370.                (function input-c-conversion-fn)
  371.                avars arg-types))
  372.      (res-conversion (output-c-conversion-fn res-type))
  373.      (fn-call (apply-conversion res-conversion `(,new-lisp-fn ,@avars))))
  374.      (values
  375.       (if io?
  376.       `(define (,new-fn ,@avars ignored-state)
  377.          (declare (ignore ignored-state))
  378.          ,@arg-conversions
  379.          ,fn-call)
  380.       `(define (,new-fn ,@avars)
  381.          ,@arg-conversions
  382.          ,fn-call))
  383.       `(define-c-function ,c-name ,new-lisp-fn ,res-type ,@arg-types)
  384.       new-fn)))
  385.  
  386. (define (input-c-conversion-fn ty)
  387.   (cond ((eq? ty ':c-string)
  388.      (lambda (x) `(haskell-string->string ,x)))
  389.     ((eq? ty ':char)
  390.      (lambda (x) `(integer->char ,x)))
  391.     (else
  392.      '#f)))
  393.  
  394. (define (output-c-conversion-fn ty)
  395.   (cond ((eq? ty ':c-string)
  396.      (lambda (x) `(make-haskell-string ,x)))
  397.     ((eq? ty ':void)
  398.      (lambda (x) `(insert-unit-value ,x)))
  399.     ((eq? ty ':char)
  400.      (lambda (x) `(char->integer ,x)))
  401.     (else
  402.      '#f)))
  403.  
  404.  
  405. ;;; This converts a Haskell type to a C type.  The one special case here is
  406. ;;; that a unit type is translated to :void.
  407.  
  408. (define (convert-to-c-type ty)
  409.   (if (and (ntycon? ty)
  410.        (eq? (ntycon-tycon ty) (core-symbol "UnitType")))
  411.       ':void
  412.       (let ((ctype (haskell-type->c-type ty)))
  413.     (or ctype
  414.         (phase-error 'c-type-required "Not a C type: ~A" ty)))))
  415.  
  416. ;;; This is the basic type converter - a fixed set of C types, as declared in
  417. ;;; PreludeC, is translated into the C type system used by mumble.
  418.  
  419. (define (haskell-type->c-type ty)
  420.   (if (not (ntycon? ty))
  421.       '#f
  422.       (let* ((tycon (ntycon-tycon ty))
  423.               (name (def-name tycon)))
  424.     (if (not (def-core? tycon))
  425.         '#f
  426.         (cond ((eq? name '|C_char|)
  427.            :char)
  428.               ((eq? name '|C_short|)
  429.            :short)
  430.               ((eq? name '|C_int|)
  431.            :int)
  432.               ((eq? name '|C_long|)
  433.            :long)
  434.               ((eq? name '|C_unsigned_char|)
  435.            :unsigned-char)
  436.               ((eq? name '|C_unsigned_short|)
  437.            :unsigned-short)
  438.               ((eq? name '|C_unsigned_int|)
  439.            :unsigned-int)
  440.               ((eq? name '|C_unsigned_long|)
  441.            :unsigned-long)
  442.               ((eq? name '|C_float|)
  443.            :float)
  444.               ((eq? name '|C_double|)
  445.            :double)
  446.               ((eq? name '|C_void|)
  447.            :void)
  448.               ((eq? name '|C_bool|)
  449.            :bool)
  450.               ((eq? name '|C_string|)
  451.            :c-string)
  452.           (else (error "Invalid C type ~s." tycon))
  453.           )))))
  454.