;;; open-coding primitive procedures

;; Copyright (C) 2009-2015, 2017 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il primitives)
  #:use-module (system base pmatch)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (system base syntax)
  #:use-module (language tree-il)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-16)
  #:export (resolve-primitives add-interesting-primitive!
            expand-primcall expand-primitives
            effect-free-primitive? effect+exception-free-primitive?
            constructor-primitive?
            singly-valued-primitive? equality-primitive?
            bailout-primitive?
            negate-primitive))

;; When adding to this, be sure to update *multiply-valued-primitives*
;; if appropriate.
(define *interesting-primitive-names* 
  '(apply
    call-with-values
    call-with-current-continuation
    call/cc
    dynamic-wind
    values
    eq? eqv? equal?
    memq memv
    = < > <= >= zero? positive? negative?
    + * - / 1- 1+ quotient remainder modulo
    ash logand logior logxor lognot logtest logbit?
    sqrt abs
    not
    pair? null? list? symbol? vector? string? struct? number? char? nil?
    bytevector? keyword? bitvector?

    procedure? thunk?

    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?

    char<? char<=? char>=? char>?

    integer->char char->integer number->string string->number

    acons cons cons*

    list vector

    car cdr
    set-car! set-cdr!

    caar cadr cdar cddr

    caaar caadr cadar caddr cdaar cdadr cddar cdddr

    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr

    length

    make-vector vector-length vector-ref vector-set!
    variable? variable-ref variable-set!
    variable-bound?

    current-module define!

    current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state

    call-with-prompt
    abort-to-prompt* abort-to-prompt
    make-prompt-tag

    throw error scm-error

    string-length string-ref string-set!

    allocate-struct struct-vtable make-struct/no-tail struct-ref struct-set!

    bytevector-length

    bytevector-u8-ref bytevector-u8-set!
    bytevector-s8-ref bytevector-s8-set!
    u8vector-ref u8vector-set! s8vector-ref s8vector-set!
    
    bytevector-u16-ref bytevector-u16-set!
    bytevector-u16-native-ref bytevector-u16-native-set!
    bytevector-s16-ref bytevector-s16-set!
    bytevector-s16-native-ref bytevector-s16-native-set!
    u16vector-ref u16vector-set! s16vector-ref s16vector-set!
    
    bytevector-u32-ref bytevector-u32-set!
    bytevector-u32-native-ref bytevector-u32-native-set!
    bytevector-s32-ref bytevector-s32-set!
    bytevector-s32-native-ref bytevector-s32-native-set!
    u32vector-ref u32vector-set! s32vector-ref s32vector-set!
    
    bytevector-u64-ref bytevector-u64-set!
    bytevector-u64-native-ref bytevector-u64-native-set!
    bytevector-s64-ref bytevector-s64-set!
    bytevector-s64-native-ref bytevector-s64-native-set!
    u64vector-ref u64vector-set! s64vector-ref s64vector-set!
    
    bytevector-ieee-single-ref bytevector-ieee-single-set!
    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
    bytevector-ieee-double-ref bytevector-ieee-double-set!
    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))

(define (add-interesting-primitive! name)
  (hashq-set! *interesting-primitive-vars*
              (or (module-variable (current-module) name)
                  (error "unbound interesting primitive" name))
              name))

(define *interesting-primitive-vars* (make-hash-table))

(for-each add-interesting-primitive! *interesting-primitive-names*)

(define *primitive-constructors*
  ;; Primitives that return a fresh object.
  '(acons cons cons* list vector make-vector
    allocate-struct make-struct/no-tail
    make-prompt-tag))

(define *primitive-accessors*
  ;; Primitives that are pure, but whose result depends on the mutable
  ;; memory pointed to by their operands.
  ;;
  ;; Note: if you add an accessor here, be sure to add a corresponding
  ;; case in (language tree-il effects)!
  '(vector-ref
    car cdr
    memq memv
    struct-ref
    string-ref
    bytevector-u8-ref bytevector-s8-ref
    bytevector-u16-ref bytevector-u16-native-ref
    bytevector-s16-ref bytevector-s16-native-ref
    bytevector-u32-ref bytevector-u32-native-ref
    bytevector-s32-ref bytevector-s32-native-ref
    bytevector-u64-ref bytevector-u64-native-ref
    bytevector-s64-ref bytevector-s64-native-ref
    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))

(define *effect-free-primitives*
  `(values
    eq? eqv? equal?
    = < > <= >= zero? positive? negative?
    ash logand logior logxor lognot logtest logbit?
    + * - / 1- 1+ sqrt abs quotient remainder modulo
    not
    pair? null? nil? list?
    symbol? variable? vector? struct? string? number? char?
    bytevector? keyword? bitvector? atomic-box?
    complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
    char<? char<=? char>=? char>?
    integer->char char->integer number->string string->number
    struct-vtable
    length string-length vector-length bytevector-length
    ;; These all should get expanded out by expand-primitives.
    caar cadr cdar cddr
    caaar caadr cadar caddr cdaar cdadr cddar cdddr
    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
    ,@*primitive-constructors*
    ,@*primitive-accessors*))

;; Like *effect-free-primitives* above, but further restricted in that they
;; cannot raise exceptions.
(define *effect+exception-free-primitives*
  '(values
    eq? eqv? equal?
    not
    pair? null? nil? list?
    symbol? variable? vector? struct? string? number? char?
    bytevector? keyword? bitvector?
    procedure? thunk? atomic-box?
    acons cons cons* list vector))

;; Primitives that don't always return one value.
(define *multiply-valued-primitives* 
  '(apply
    call-with-values
    call-with-current-continuation
    call/cc
    dynamic-wind
    values
    call-with-prompt
    @abort abort-to-prompt))

;; Procedures that cause a nonlocal, non-resumable abort.
(define *bailout-primitives*
  '(throw error scm-error))

;; Negatable predicates.
(define *negatable-primitives*
  '((even? . odd?)
    (exact? . inexact?)
    ;; (< <= > >=) are not negatable because of NaNs.
    (char<? . char>=?)
    (char>? . char<=?)))

(define *equality-primitives*
  '(eq? eqv? equal?))

(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
(define *equality-primitive-table* (make-hash-table))
(define *multiply-valued-primitive-table* (make-hash-table))
(define *bailout-primitive-table* (make-hash-table))
(define *negatable-primitive-table* (make-hash-table))

(for-each (lambda (x)
            (hashq-set! *effect-free-primitive-table* x #t))
          *effect-free-primitives*)
(for-each (lambda (x) 
            (hashq-set! *effect+exceptions-free-primitive-table* x #t))
          *effect+exception-free-primitives*)
(for-each (lambda (x)
            (hashq-set! *equality-primitive-table* x #t))
          *equality-primitives*)
(for-each (lambda (x) 
            (hashq-set! *multiply-valued-primitive-table* x #t))
          *multiply-valued-primitives*)
(for-each (lambda (x)
            (hashq-set! *bailout-primitive-table* x #t))
          *bailout-primitives*)
(for-each (lambda (x)
            (hashq-set! *negatable-primitive-table* (car x) (cdr x))
            (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
          *negatable-primitives*)

(define (constructor-primitive? prim)
  (memq prim *primitive-constructors*))
(define (effect-free-primitive? prim)
  (hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
  (hashq-ref *effect+exceptions-free-primitive-table* prim))
(define (equality-primitive? prim)
  (hashq-ref *equality-primitive-table* prim))
(define (singly-valued-primitive? prim)
  (not (hashq-ref *multiply-valued-primitive-table* prim)))
(define (bailout-primitive? prim)
  (hashq-ref *bailout-primitive-table* prim))
(define (negate-primitive prim)
  (hashq-ref *negatable-primitive-table* prim))

(define (resolve-primitives x mod)
  (define local-definitions
    (make-hash-table))

  ;; Assume that any definitions with primitive names in the root module
  ;; have the same semantics as the primitives.
  (unless (eq? mod the-root-module)
    (let collect-local-definitions ((x x))
      (record-case x
        ((<toplevel-define> name)
         (hashq-set! local-definitions name #t))
        ((<seq> head tail)
         (collect-local-definitions head)
         (collect-local-definitions tail))
        (else #f))))
  
  (post-order
   (lambda (x)
     (or
      (record-case x
        ((<toplevel-ref> src name)
         (and=> (and (not (hashq-ref local-definitions name))
                     (hashq-ref *interesting-primitive-vars*
                                (module-variable mod name)))
                (lambda (name) (make-primitive-ref src name))))
        ((<module-ref> src mod name public?)
         ;; for the moment, we're disabling primitive resolution for
         ;; public refs because resolve-interface can raise errors.
         (and=> (and=> (resolve-module mod)
                       (if public?
                           module-public-interface
                           identity))
                (lambda (m)
                  (and=> (hashq-ref *interesting-primitive-vars*
                                    (module-variable m name))
                         (lambda (name)
                           (make-primitive-ref src name))))))
        ((<call> src proc args)
         (and (primitive-ref? proc)
              (make-primcall src (primitive-ref-name proc) args)))
        (else #f))
      x))
   x))