/[gcl]/gcl/pargcl/src/mpi_glue.lsp
ViewVC logotype

Diff of /gcl/pargcl/src/mpi_glue.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by gene, Sat Oct 29 05:12:15 2005 UTC revision 1.3 by gene, Mon Oct 31 08:10:45 2005 UTC
# Line 1  Line 1 
1  ;;;; Copyright (c) Gene Cooperman, 1994-2002  ;;;; Copyright (c) Gene Cooperman, 1994-2005
2  ;;;;  Rights to use this code for any purpose are freely granted,  
3  ;;;;  so long as this notice remains.  No warranty is given for the  ;; This file is part of ParGCL.
4  ;;;;  correctness or suitability of this code.  ;;
5    ;; ParGCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; ParGCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with ParGCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19  (in-package "MPI")  (in-package "MPI")
20    
# Line 28  Line 41 
41  ;;;This file MUST be compiled, and loaded compiled, or C fnc's not found  ;;;This file MUST be compiled, and loaded compiled, or C fnc's not found
42  ;;;Unfortunately, AKCL already has integrated another MPI package:  ;;;Unfortunately, AKCL already has integrated another MPI package:
43  ;;;  Multiple Precision Integers, while here, MPI = Message Passing Interface  ;;;  Multiple Precision Integers, while here, MPI = Message Passing Interface
44    ;;;  In GCL 2.7.0, this seems to be replaced by gmp (GNU Multiple Prec), anyway.
45  ;;;  Hopefully this presents no conflict or confusion, since at the  ;;;  Hopefully this presents no conflict or confusion, since at the
46  ;;;  the user level, MPI is always Message Passing Interface  ;;;  the user level, MPI is always Message Passing Interface
47  ;;;BUG:  MPI and LISP compete for same signals (interrupt, etc.)  ;;;BUG:  MPI and LISP compete for same signals (interrupt, etc.)
# Line 52  Line 66 
66        (return (- i 2)))))        (return (- i 2)))))
67  (eval-when (compile)  (eval-when (compile)
68  (defmacro make-fill-string (len)  (defmacro make-fill-string (len)
69    `(make-array ,len :element-type 'string-char :fill-pointer t :static t))    `(make-array ,len :element-type 'character :fill-pointer t :static t))
70  )  )
71    
72  ;;;character macro:  $ ...  ==>  "..."  ;;;character macro:  $ ...  ==>  "..."
# Line 183  $ static int MPI_Status_Tag () { return Line 197  $ static int MPI_Status_Tag () { return
197  $ static MPI_Datatype MPI_type[3];  $ static MPI_Datatype MPI_type[3];
198  $ static void MPI_Init_Datatype()  $ static void MPI_Init_Datatype()
199  $ { /* must be set only after running MPI_Init; MPI_CHAR is var, not const */  $ { /* must be set only after running MPI_Init; MPI_CHAR is var, not const */
200  $  MPI_type[0] = MPI_CHAR /* STRING-CHAR */;  $  MPI_type[0] = MPI_CHAR /* CHARACTER */;
201  $  MPI_type[1] = MPI_INT /* FIXNUM */;  $  MPI_type[1] = MPI_INT /* FIXNUM */;
202  $/* printf("debugging: %d %d %d\n", MPI_type[0], MPI_CHAR, MPI_INT); */  $/* printf("debugging: %d %d %d\n", MPI_type[0], MPI_CHAR, MPI_INT); */
203  $  MPI_type[2] = MPI_FLOAT /*  */;}  $  MPI_type[2] = MPI_FLOAT /*  */;}
204  )  )
205  (defconstant STRING-CHAR 0)  (defconstant CHARACTER 0)
206  (defconstant FIXNUM 1)  (defconstant FIXNUM 1)
207  (defconstant FLOAT 2)  (defconstant FLOAT 2)
208    ;;; Was called string-char in GCL 2.6.0, but character in GCL 2.7.0
209  (defconstant *type-lisp-to-mpi*  (defconstant *type-lisp-to-mpi*
210             `((string-char . ,STRING-CHAR) (fixnum . ,FIXNUM) (float . ,FLOAT)))             `((character . ,CHARACTER) (string-char . ,CHARACTER)
211                 (fixnum . ,FIXNUM) (float . ,FLOAT)))
212  (Clines  (Clines
213  $ static int MPI_Any_Source () { return MPI_ANY_SOURCE; }  $ static int MPI_Any_Source () { return MPI_ANY_SOURCE; }
214  $ static int MPI_Any_Tag () { return MPI_ANY_TAG; }  $ static int MPI_Any_Tag () { return MPI_ANY_TAG; }
# Line 265  $ static int MPI_Any_Tag () { return MPI Line 281  $ static int MPI_Any_Tag () { return MPI
281      (if (symbolp datatype)      (if (symbolp datatype)
282        (setq datatype        (setq datatype
283              (case datatype              (case datatype
284                (string-char 0)                (character 0)
285                (fixnum 1)                (fixnum 1)
286                (float 2)                (float 2)
287                (otherwise (error "unsupported datatype for MPI-Get-count"))))))                (otherwise (error "unsupported datatype for MPI-Get-count"))))))
# Line 351  $ static int MPI_Any_Tag () { return MPI Line 367  $ static int MPI_Any_Tag () { return MPI
367                   &aux (datatype (array-element-type msg)) (len (length msg)))                   &aux (datatype (array-element-type msg)) (len (length msg)))
368        (setq datatype (or (cdr (assoc datatype *type-lisp-to-mpi*))        (setq datatype (or (cdr (assoc datatype *type-lisp-to-mpi*))
369                          (error "msg is array of bad elt. type: ~a" datatype)))                          (error "msg is array of bad elt. type: ~a" datatype)))
370          (if (>= dest (MPI-World-size))
371            (error "destination ~a is larger than maximum rank of processes" dest))
372          (if (< dest 0)
373            (error "destination ~a is negative" dest))
374        (if (not (staticp msg))        (if (not (staticp msg))
375            (error "MPI-Send:  msg buffer not static array")))            (error "MPI-Send:  msg buffer not static array")))
376    (MPI-Send-glue msg len datatype dest tag)    (MPI-Send-glue msg len datatype dest tag)
# Line 358  $ static int MPI_Any_Tag () { return MPI Line 378  $ static int MPI_Any_Tag () { return MPI
378         (object buf) (int count) (int datatype) (int dest) (int tag))         (object buf) (int count) (int datatype) (int dest) (int tag))
379    ("/* printf(\"debugging:  datatype:  %x %x\\n\", MPI_CHAR, MPI_type[0]) */"    ("/* printf(\"debugging:  datatype:  %x %x\\n\", MPI_CHAR, MPI_type[0]) */"
380     "return MPI_Send(buf->st.st_self, count, MPI_type[datatype], dest, tag, MPI_COMM_WORLD)")     "return MPI_Send(buf->st.st_self, count, MPI_type[datatype], dest, tag, MPI_COMM_WORLD)")
381    "args: msg (string or (array fixnum)), dest (fixnum rank), tag (fixnum);    "args: msg (string or (array fixnum) or (array float)), dest (fixnum rank),
382         tag argument is optional;         tag (fixnum);  [ tag argument is optional ]
383         msg MUST be static array.  See (make-array ... static t);         msg MUST be static array.  See (make-array ... :static t);
384         side-effects status variable; (apropos \"MPI-Status\") for more info;         side-effects status variable; (apropos \"MPI-Status\") for more info;
385         data in all of array is sent to receiver, but if it has         data in all of array is sent to receiver, but if it has
386         a fill-pointer, only the data up to the fill-pointer is sent.")         a fill-pointer, only the data up to the fill-pointer is sent.")
# Line 379  $ static int MPI_Any_Tag () { return MPI Line 399  $ static int MPI_Any_Tag () { return MPI
399                          See examples/example-mpi.lsp"))                          See examples/example-mpi.lsp"))
400              (setq datatype (array-element-type buf))              (setq datatype (array-element-type buf))
401              (setq count (array-dimension buf 0))              (setq count (array-dimension buf 0))
402                (if (>= source (MPI-World-size))
403                  (error "source ~a is larger than maximum rank of processes"
404                         source))
405                (if (< source 0)
406                  (error "source ~a is negative" source))
407              (setq datatype (or (cdr (assoc datatype *type-lisp-to-mpi*))              (setq datatype (or (cdr (assoc datatype *type-lisp-to-mpi*))
408                          (error "buf is array of bad elt. type: ~a~%  ~                          (error "buf is array of bad elt. type: ~a~%  ~
409                See *type-lisp-to-mpi* for list of acceptable types" datatype))))                See *type-lisp-to-mpi* for list of acceptable types" datatype))))
# Line 395  $ static int MPI_Any_Tag () { return MPI Line 420  $ static int MPI_Any_Tag () { return MPI
420     "                        (buf->v.v_fillp)=count;}"     "                        (buf->v.v_fillp)=count;}"
421     "settimer()"     "settimer()"
422     "return(buf)")     "return(buf)")
423    "args: buf (array string-char/fixnum), source (fixnum rank),    "args: buf (array character/fixnum/float), source (fixnum rank),
424           <opt: tag(fixnum)>;           <opt: tag(fixnum)>;
425     all arguments optional;     all arguments optional;
426     side-effects status variable; (apropos \"MPI-Status\") for more info;     side-effects status variable; (apropos \"MPI-Status\") for more info;
# Line 485  $ static int MPI_Any_Tag () { return MPI Line 510  $ static int MPI_Any_Tag () { return MPI
510    
511  ;;;;; THIS MUST BE LAST  ;;;;; THIS MUST BE LAST
512  (do-symbols (var "MPI") (if (fboundp var) (export var "MPI")))  (do-symbols (var "MPI") (if (fboundp var) (export var "MPI")))
 ;;These shouldn't be in LISP package.  But make_special was putting them there.  
513  (dolist (x '(LISP::mpi-tag-ub LISP::mpi-host LISP::mpi-io)) (export x "LISP"))  (dolist (x '(LISP::mpi-tag-ub LISP::mpi-host LISP::mpi-io)) (export x "LISP"))
514  (pushnew 'MPI *features*)  (pushnew :MPI *features*)
515    ;;These shouldn't be in LISP package.  But make_special was putting them there.
516  (eval-when (compile eval) (setq *readtable* %old-readtable%))  (eval-when (compile eval) (setq *readtable* %old-readtable%))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26